系统分析大作业系列博客二：shiny简介与应用搭建

shiny应用与搭建

简介

因为系统分析设计课程作业需要设计一个小型挣闲钱网站应用的开发。自己每周日花了点时间先做了一个其他应用的demo来熟悉相应开发流程，虽然最后没有小组选择传统的restful架构然后这部分内容并没有在后续阶段中获得相应使用，留此博客作为该阶段学习的笔记。

在选择相应的开发工具时，想到了之前一直想了解，但没有去深入学习的R shiny框架，作为一个R语言的死粉，当然要紧跟着rstudio的脚步啦。

这里对R shiny做一个简单介绍，shiny是一个基于R语言的快速网站开发框架，对相应网站前后端高度封装，采用前后端分离技术

第一个强大之处在于高度封装，对于shiny应用，主要编写两个模块,ui模块与server模块，ui模块中的output类与server模块的render类进行相互的辅助达到相应的交互效果。

R shiny的另一个强大之处在于对原生网站开发工具的兼容性，在R shiny中可以使用jquery, vue, react等工具。

此外，相对于其他网站开发流程，R shiny app的部署相对便捷，shinyapps.io提供用户免费部署应用的服务，虽然拥有一些限制（应用个数等），但是无需申请租用服务器，若自己拥有服务器，则可在服务器上安装rstudio提供的shiny server。

好了，来谈谈我们的项目

使用的包

总所周知，R的包是非常强大的，这里我们采用下列包来搭建相应应用

library(shiny)
library(DT)
library(shinyWidgets)
library(rvest)
library(plyr)
library(shinymaterial)
library(shinyAce)
library(shiny)
library(ggplot2)
library(ggthemr)
library(shinythemes)
library(shinydashboard)
library(dashboardthemes)
library(shinycssloaders)
library(leaflet)
library(shinyjs)
library(weatherr)
library(RMySQL)
library(sweetalertR)

数据获取

因为是demo，所以没有将数据库加入我们的应用中，所有数据均从网页api中获取，这里采用网上的相应api访问代码，封装为相应函数。

fetchData <- function(city, date){
  
  baseUrl <- 'http://lishi.tianqi.com/'
  Url <- paste(baseUrl, city, '/', date, '.html', sep = '')
  
  content <- Url %>%
    read_html(encoding='GBK') %>%
    html_nodes('div.tqtongji2') %>%
    html_nodes("ul") %>%
    html_text() %>%
    strsplit("\\s{4,}")
  
  content <- ldply(content[-1])
  names(content) <- c('date', 'highDegree', 'lowDegree', 'weather', 'windDirection', 'windForce')
  return(content) 
}
fetchData2 <- function(city, date){
  date <- paste(substring(date,first=0, last=4) , substring(date,first = 6,last = 7), sep ="")
  baseUrl <- 'http://lishi.tianqi.com/'
  Url <- paste(baseUrl, city, '/', date, '.html', sep = '')
  
  content <- Url %>%
    read_html(encoding='GBK') %>%
    html_nodes('div.tqtongji2') %>%
    html_nodes("ul") %>%
    html_text() %>%
    strsplit("\\s{4,}")
  
  content <- ldply(content[-1])
  names(content) <- c('date', 'highDegree', 'lowDegree', 'weather', 'windDirection', 'windForce')
  return(content) 
}
fetchPredict <- function(mode)
{
  lng <- c(113.3244465713, 115.89, 116.46)
  lat <- c(23.1064679044, 28.68, 39.92)
  mode <- as.numeric(mode)
  print(mode)
  print(lng[mode])
  data <- locationforecast(lat[mode], lng[mode])
  return(data)
}

ui类编写

先上图吧

这里写图片描述

相应的有一些模块不满意就不展示了，虽然那个地图部分比较丑，暂时没有想到合理的布局来改善。

这里相应的ui部分代码如下

ui2 <- dashboardPage(
  
  dashboardHeader(
    #title="Haide"
    title = logo_blue_gradient,
    tags$li(class = "dropdown", 
            uiOutput("S")
            
            #sweetalert(selector = "#Signin", text = "Signin", title = "world")
            
            
    )
    
    #actionButton("Go","Go")
  ),
  dashboardSidebar(
    sidebarMenu(
      menuItem("graphics", tabName = "graphics", icon = icon("dashboard")),
      menuItem("table", icon = icon("th"), tabName = "table"),
      menuItem("map", tabName = "map", icon = icon("map-marker",lib = "glyphicon")),
      menuItem("predict", icon = icon("flag",lib = "glyphicon"), tabName = "predict"),
      menuItem("feedback", tabName = "feedback", icon = icon("pencil",lib = "glyphicon")),
      menuItem("user",tabName = "user",icon = icon("user",lib = "glyphicon")),
      menuItem("info", icon = icon("header",lib = "glyphicon"), tabName = "info")
    )
  ),
  dashboardBody(
    #theme="style.css",
    shinyDashboardThemes(
      theme = "blue_gradient"
    ),
    includeCSS("www/style.css"),
    
    fluidRow(
      tabItems(
        tabItem(tabName = "graphics",
                sidebarLayout(
                  position = "right",
                  sidebarPanel(
                    h4("select what you want here"),
                    selectInput("select", h3("Select city"), choices = 
                                  list("广州" = 'guangzhou', "南昌" = 'nanchang',
                                       "北京" = 'beijing'), selected = 2),
                    dateInput("date", h3("Date input"), value = "2018-03-03"),
                    selectInput("select_theme", h3("Select theme"), choices = list("dust" = "dust", "earth" = "earth","light" = "light", "pale" ="pale" , "fresh" = "fresh","chalk"="chalk","light"="light","sky"="sky","grass"="grass","grape"="grape"), selected = "fresh")
                    ,bookmarkButton(id = "bookmark")
                    
                  ),
                  mainPanel(
                    plotOutput("plot_point")%>% withSpinner(type=4),
                    plotOutput("plot_line")%>% withSpinner(type=4),
                    plotOutput("plot_bar")%>% withSpinner(type=4)
                  )
                )
        ),
        
        tabItem(tabName = "table",
                sidebarLayout(
                  position = "right",
                  sidebarPanel(
                    h4("select what you want here"),
                    selectInput("select2", h3("Select city"), choices = 
                                  list("广州" = 'guangzhou', "南昌" = 'nanchang',
                                       "北京" = 'beijing'), selected = 2),
                    dateInput("date2", h3("Date input"), value = "2018-03-03")
                    ,downloadButton("downloadData", "Download"),
                    
                    checkboxGroupInput("show_vars", "Columns in tables to show:",
                                       c("date"="date","highDegree"="highDegree","lowDegree"="lowDegree", "weather"="weather","windDirection"="windDirection"), selected = c("date"="date","highDegree"="highDegree","lowDegree"="lowDegree", "weather"="weather","windDirection"="windDirection")
                                       
                    )),
                  mainPanel(
                    DT::dataTableOutput('table')%>% withSpinner(type=4)
                  )
                )
                
        ),
        tabItem(tabName = "map",
                sidebarPanel(
                  h5("basic geo information"),
                  textOutput("geo")
                  ,h5("temparature now")
                  ,textOutput("wea")
                ),
                mainPanel(
                  leafletOutput("map")%>% withSpinner(type=4)
                )
        ),
        
        tabItem(tabName = "predict",
                sidebarLayout(
                  sidebarPanel(
                    selectInput("select4", h3("Select city"), choices = 
                                  list("广州" = 1, "南昌" = 2,
                                       "北京" = 3), selected = 2),
                    checkboxGroupInput("show_vars2", "Columns in tables to show:",
                                       c("time"="time","temperature"="temperature","humidity"="humidity"),selected = c("time"="time","temperature"="temperature","humidity"="humidity"))
                    
                  ),
                  mainPanel(
                    DT::dataTableOutput('table4')%>% withSpinner(type=4)
                  )
                )
        ),
        tabItem(tabName = "feedback",
                sidebarLayout(
                  sidebarPanel(
                    h5("Thanks for giving us valuable feedback"),
                    actionButton("reset", "Reset text"),
                    actionButton("submit", "submit"),
                    material_button(
                      input_id = "example_button",
                      label = "BUTTON",
                      depth = 10
                    )
                  ),
                  
                  mainPanel(
                    aceEditor("ace",fontSize = 20,autoComplete = "enabled",theme="ambiance")
                  )
                )
        ),
        tabItem(tabName = "user",
                uiOutput("user-info")
        ),
        tabItem(tabName = "info",
                sidebarLayout(
                  sidebarPanel("information",
                               h5("maintainer: Ralph Haide"),
                               h5("version: 1.3.0"),
                               h6("contact me:"),
                               a("ralphshaides@gmail.com")
                               
                  ),
                  mainPanel(
                    
                    img(src="https://s1.ax1x.com/2018/04/15/CeieW6.png",width=200,height=200),
                    br(),
                    h2("Haide",aign="center"),
                    h3("a simple weather application powered by shiny",align="left"),
                    h5("technology used: ",",",a("R",href="https://www.r-project.org/"),",", a("shiny",href="http://shiny.rstudio.com/") ,",", "Crawler" ,",", a("ggplot2",href="http://ggplot2.org/")),
                    h5("library used:", a("shiny",href="http://shiny.rstudio.com/") , a("DT"), a("ggplot2",href="http://ggplot2.org/"), a("ggthemr",href="https://cran.r-project.org/web/packages/ggthemes/index.html"), a("plyr",href="https://cran.r-project.org/web/packages/plyr/index.html"), a("rvest",href="https://cran.r-project.org/web/packages/rvest/index.html"),a("weatherR",href="https://cran.r-project.org/web/packages/weatherr/index.html"))
                    ,includeMarkdown("log.md")
                  )                    
                )
        )
      ))
  )
)

这里主要就是安排布局与相应的输入输出单元

server端编写

这里的server端主要处理网站的输出做逻辑规划，使用render类函数来对网站进行渲染。具体请查看相应文档。

server <- function(input, output,session) {
  
  output$selected_var <- renderText({ 
    paste("city selected: " , input$select, " ")
  })
  output$plot_point <- renderPlot({
    ggthemr(input$select_theme)
    name <- as.character(input$date)
    city <- input$select
    name <- paste(substring(name,first=0, last=4) , substring(name,first = 6,last = 7), sep ="")
    weatherData <- fetchData(city,name)
    len <- length(weatherData$date)
    ggplot(weatherData, aes(x=lowDegree, y=highDegree)) + geom_point()
  })
  output$plot_bar <- renderPlot({
    ggthemr(input$select_theme)
    name <- as.character(input$date)
    city <- input$select
    name <- paste(substring(name,first=0, last=4) , substring(name,first = 6,last = 7), sep ="")
    weatherData <- fetchData(city,name)
    len <- length(weatherData$date)
    day <- rep(seq(1, len),2)
    day <- day + 1
    degrees <- as.numeric(c(weatherData$lowDegree, weatherData$highDegre))
    tags <- rep(c("low","high"),each=len)
    data <- data.frame(day, degrees,tags)
    option = input$select_shape
    option = as.numeric(option)
    ggplot(data, aes(x = day, y = degrees , fill=tags)) +geom_bar(stat= 'identity', width = 0.5, position =  position_dodge(0.7))
  })
  output$plot_line <- renderPlot({
    ggthemr(input$select_theme)
    name <- as.character(input$date)
    city <- input$select
    name <- paste(substring(name,first=0, last=4) , substring(name,first = 6,last = 7), sep ="")
    weatherData <- fetchData(city,name)
    len <- length(weatherData$date)
    day <- rep(seq(1, len),2)
    day <- day + 1
    degrees <- as.numeric(c(weatherData$lowDegree, weatherData$highDegre))
    tags <- rep(c("low","high"),each=len)
    data <- data.frame(day, degrees,tags)
    option = input$select_shape
    option = as.numeric(option)
    ggplot(data, aes(x = day, y = degrees , color=tags)) + geom_point() + geom_line()
  })
  output$table <- DT::renderDataTable({
    fetchData2(input$select2,as.character(input$date2))[,input$show_vars, drop=FALSE]
  }
  )
  output$table4 <- DT::renderDataTable({
    fetchPredict(input$select4)[,input$show_vars2, drop=FALSE]
  }
  )
  output$downloadData <- downloadHandler(
    filename = function() {
      paste('data-', Sys.Date(), '.csv', sep='')
    },
    content = function(con) {
      data <- fetchData2(input$select2,as.character(input$date2))
      write.csv(data[,-1], con,row.names = TRUE)
    }
  )
  observeEvent(input$bookmark, {
    session$doBookmark()
  })
  
  output$map <- renderLeaflet({
    leaflet() %>%
      addTiles() %>%  
      addMarkers(lng=115.89, lat=28.68,
                 popup="南昌",label = "南昌") %>%
      addMarkers(lng=113.3244465713,lat=23.1064679044,popup="广州",label = "广州") %>%
      addMarkers(lng=116.46,lat=39.92,popup="北京",label = "北京") %>%
      addMarkers(lng=114.30, lat=30.60,popup="武汉",label = "武汉")%>%addMiniMap()%>%addMeasure()
    
    
  })
  observeEvent(input$map_marker_click,{
    print("observed map_marker_click")
    p <- input$map_marker_click
    print(p)
    str <- paste(p$lat," , ",p$lng)
    print(str)
    output$geo <- renderText({ 
      str
    })
    output$wea <- renderText({
      data <- locationforecast(p$lat, p$lng)
      as.character(data$temperature[1])
    })
  })
  observeEvent(input$map_click,{
    print("observed map_marker_click")
    p <- input$map_click
    print(p)
    str <- paste(p$lat," , ",p$lng)
    print(str)
    output$geo <- renderText({ 
      str
    })
    output$wea <- renderText({
      data <- locationforecast(p$lat, p$lng)
      as.character(data$temperature[1])
    })
  }
  )
  observeEvent(input$reset, {
    updateAceEditor(session, "ace", value = "")
    
  })
  observeEvent(input$submit,{
    str = as.character(input$ace)
    print(str)
  })
  
  output$S <- renderUI({
    if (!s$signin){
      actionButton("Signin", "signin")
    }
    else{
      #actionButton("Signi", "Signi") 
      img(src="user.png",width = 40, height = 40,align="left",id="user")
    }
  })
  observeEvent(input$Signin, {
    sendSweetAlert(
      session = session,
      title = "Success !!",
      text = "All in order",
      type = "success"
    )
    s$signin = TRUE
    #print(signin)
  })
  output$"user-info" <- renderUI({
    if (!s$signin){
      h3("you are not allowed to view this page before signin")
    }
    else{
      fluidRow(
        sidebarLayout(
          sidebarPanel(),
          mainPanel(
            valueBox(10 * 2, "New Orders", icon = icon("credit-card"))
          )
        )
      ) 
      
    }
  })
}

网站应用的运行与部署

若需要运行该应用，需要添加下面的一份代码

1	app <- shinyApp(ui = ui2, server = server)

若希望将其部署到shinyapps.io，可以使用rstudio的相应publish功能，添加相应shinyapps.io账户，进行部署

此外

这里展示了部分代码，若需要查看完整代码，欢迎来fork该项目Haide

Haide

系统分析大作业系列博客二