R-----shiny包的部分解释和控件介绍

R-----shiny包的部分解释和控件介绍

作者：周彦通、贾慧

shinyApp(

ui = fixedPage(

fixedPanel(

top = 50, right=50, width=200, draggable = TRUE, style="padding: 20px; border: 1px solid red;",

"可以移动的框框1"

),

absolutePanel(

top = 150, right=150, width=200, draggable = TRUE, style="padding: 20px; border: 1px solid red;",

"可以移动的框框2"

)

),

server = function(session, input, output) {

})

shinyApp(

ui = fixedPage(

tags$head(

tags$title('窗口标题'),

tags$style(

rel = 'stylesheet',

'.title-panel {background: #ABCDEF} ',

'.title-panel h2 {text-align:center; color: #FF0000}'

)

),

div(

class='col-md-12 title-panel',

h2('页面标题')

)

),

server = function(input, output, session) {}

)

shinyApp(

ui = fixedPage(

tags$style(

".container div {border: 1px solid gray; min-height:30px;}",

"h4 {color:red; margin-top: 20px;}"

),

h4("两栏模板"),

sidebarLayout(

sidebarPanel("side bar panel"),

mainPanel("main panel")

),

h4("垂直分割模板"),

splitLayout("aaaa", "bbbb", "cccc", "dddd"),

h4("垂直排列模板"),

verticalLayout("aaaa", "bbbb", "cccc", "dddd"),

h4("流式（自动折行）模板"),

flowLayout("aaaa", "bbbb", "cccc", "dddd")

),

server = function(session, input, output) {

}

)

排版样式

shinyApp(

ui = fixedPage(

textInput('itx1', '', value='1111'),

textInput('itx2', '', value='2222'),

textOutput('otx', container=pre)

),

server = function(input, output, session) {

output$otx <- renderPrint({

a <- NULL

isolate(a <- input$itx1)

b <- input$itx2

list(a=a, b=b)

})

})

阻止响应

测试

shinyApp(

ui = fixedPage(

h1('测试'), hr(),

radioButtons('opts', '', choices = c('图像', '文字'), inline = T, selected='图像'),

conditionalPanel(

condition = 'input.opts==="图像"',

plotOutput('pl')

),

conditionalPanel(

condition = 'input.opts==="文字"',

textOutput('tx', container=pre)

)

),

server = function(input, output, session) {

air <- na.omit(airquality)

pp <- ggplot(air, aes(x=Solar.R, y=Ozone)) + geom_point()

observe({

xtype <- input$opts

if(xtype=='图像') output$pl <- renderPlot({ pp })

else output$tx <- renderPrint({ str(pp) })

})

})

文件上传

shinyApp(

ui = fixedPage(

fileInput('f', '上传文件', multi=T, accept='text/plain, image/*'),

textOutput('tx', container=pre)

),

server = function(input, output, session) {

output$tx <- renderPrint({ str(input$f) })

})

保存

library('ggplot2')fig.w <- 400fig.h <- 300shinyApp(

ui = fixedPage(

plotOutput('pl', width=fig.w, height=fig.h),

radioButtons('xtype', '图片格式', c('png', 'jpeg', 'bmp'), selected='png', inline=T),

downloadLink('file', '保存图片')

),

server = function(input, output, session) {

air <- na.omit(airquality)

pp <- ggplot(air, aes(x=Solar.R, y=Ozone)) + geom_point()

output$pl <- renderPlot({ pp })

observeEvent(

input$xtype,

output$file <- downloadHandler(

filename = paste0('plot.', input$xtype),

content = function(file) {

image <- switch(input$xtype,

png=png, jpeg=jpeg, bmp=bmp)

image(file, width=fig.w, height=fig.h)

print(pp)

dev.off()

}

)

)

})

控件

shinyApp(

ui = fixedPage(

h2('输入控件演示'),

hr(),

sidebarLayout(

sidebarPanel(

textInput('tx', '文字输入', value='abc'),

checkboxGroupInput('cg', '选项组', choice=LETTERS[1:4], selected=c('A', 'D'), inline=TRUE),

sliderInput('sl', '滑动选数', min=1, max=10, value=6),

HTML('<label for="tt">文本框输入</label>',

'<textarea id="tt" class="form-control" style="resize:none"></textarea>'

),

HTML('<label for="clx">颜色选取</label>',

'<input id="clx" type="color" class="form-control" value="#FF0000">',

'<input id="cl" type="text" class="form-control" value="#FF0000" style="display:none">',

'<script>',

'$(function(){$("#clx").change(function(){$("#cl").val($(this).val()).trigger("change");});})',

'</script>'

)

),

mainPanel(

HTML('<textarea id="ta" class="form-control shiny-text-output"',

'style="resize:none; height:200px;" readonly></textarea>'

)

)

)

),

server = function(input, output, session) {

output$ta <- renderText({

paste(c(input$tx, input$tt, paste(input$cg, collapse='; '),

input$sl, input$cl), collapse='\n')

})

observe({

updateTextInput(session, inputId='tt', value=paste('文本输入：', input$tx))

})

})

Shiny、输出语法

shinyApp(

ui = fixedPage(

textOutput('tx', container=h1),

plotOutput('pl', width='100%', height='400px')

),

server = function(input, output, session) {

output$tx <- renderText({

"这是服务器输出的文字"

})

output$pl <- renderPlot({

a <- rnorm(20)

par(mar=c(3, 3, 0.5, 0.5), mgp=c(2, 0.5, 0))

plot(a)

})

})

函数xxxOutput和renderXXX函数

ls("package:shiny", pattern="Output$")

ls("package:shiny", pattern="^render")

renderXXX函数的一般形式是：

renderXXX(expr, ...)

（红色不分为关键参数）

更新输入演示案列

Server。R

function(input, output, clientData, session) {

observe({

# We'll use these multiple times, so use short var names for

# convenience.

c_label <- input$control_label

c_num <- input$control_num

# Text =====================================================

# Change both the label and the text

updateTextInput(session, "inText",

label = paste("New", c_label),

value = paste("New text", c_num)

)

# Number ===================================================

# Change the value

updateNumericInput(session, "inNumber", value = c_num)

# Change the label, value, min, and max

updateNumericInput(session, "inNumber2",

label = paste("Number ", c_label),

value = c_num, min = c_num-10, max = c_num+10, step = 5)

# Slider input =============================================

# Only label and value can be set for slider

updateSliderInput(session, "inSlider",

label = paste("Slider", c_label),

value = c_num)

# Slider range input =======================================

# For sliders that pick out a range, pass in a vector of 2

# values.

updateSliderInput(session, "inSlider2",

value = c(c_num-1, c_num+1))

# An NA means to not change that value (the low or high one)

updateSliderInput(session, "inSlider3",

value = c(NA, c_num+2))

# Date input ===============================================

# Only label and value can be set for date input

updateDateInput(session, "inDate",

label = paste("Date", c_label),

value = paste("2013-04-", c_num, sep=""))

# Date range input =========================================

# Only label and value can be set for date range input

updateDateRangeInput(session, "inDateRange",

label = paste("Date range", c_label),

start = paste("2013-01-", c_num, sep=""),

end = paste("2013-12-", c_num, sep=""),

min = paste("2001-01-", c_num, sep=""),

max = paste("2030-12-", c_num, sep="")

)

# # Checkbox ===============================================

updateCheckboxInput(session, "inCheckbox",value = c_num %% 2)

# Checkbox group ===========================================

# Create a list of new options, where the name of the items

# is something like 'option label x A', and the values are

# 'option-x-A'.

cb_options <- list()

cb_options[[paste("option label", c_num, "A")]] <-

paste0("option-", c_num, "-A")

cb_options[[paste("option label", c_num, "B")]] <-

paste0("option-", c_num, "-B")

# Set the label, choices, and selected item

updateCheckboxGroupInput(session, "inCheckboxGroup",

label = paste("checkboxgroup", c_label),

choices = cb_options,

selected = paste0("option-", c_num, "-A")

)

# Radio group ==============================================

# Create a list of new options, where the name of the items

# is something like 'option label x A', and the values are

# 'option-x-A'.

r_options <- list()

r_options[[paste("option label", c_num, "A")]] <-

paste0("option-", c_num, "-A")

r_options[[paste("option label", c_num, "B")]] <-

paste0("option-", c_num, "-B")

# Set the label, choices, and selected item

updateRadioButtons(session, "inRadio",

label = paste("Radio", c_label),

choices = r_options,

selected = paste0("option-", c_num, "-A")

)

# Select input =============================================

# Create a list of new options, where the name of the items

# is something like 'option label x A', and the values are

# 'option-x-A'.

s_options <- list()

s_options[[paste("option label", c_num, "A")]] <-

paste0("option-", c_num, "-A")

s_options[[paste("option label", c_num, "B")]] <-

paste0("option-", c_num, "-B")

# Change values for input$inSelect

updateSelectInput(session, "inSelect",

choices = s_options,

selected = paste0("option-", c_num, "-A")

)

# Can also set the label and select an item (or more than

# one if it's a multi-select)

updateSelectInput(session, "inSelect2",

label = paste("Select label", c_label),

choices = s_options,

selected = paste0("option-", c_num, "-B")

)

# Tabset input =============================================

# Change the selected tab.

# The tabsetPanel must have been created with an 'id' argument

if (c_num %% 2) {

updateTabsetPanel(session, "inTabset", selected = "panel2")

} else {

updateTabsetPanel(session, "inTabset", selected = "panel1")

}

})}

ui.R

fluidPage(

titlePanel("Changing the values of inputs from the server"),

fluidRow(

column(3, wellPanel(

h4("These inputs control the other inputs on the page"),

textInput("control_label",

"This controls some of the labels:",

"LABEL TEXT"),

sliderInput("control_num",

"This controls values:",

min = 1, max = 20, value = 15)

)),

column(3, wellPanel(

textInput("inText",  "Text input:", value = "start text"),

numericInput("inNumber", "Number input:",

min = 1, max = 20, value = 5, step = 0.5),

numericInput("inNumber2", "Number input 2:",

min = 1, max = 20, value = 5, step = 0.5),

sliderInput("inSlider", "Slider input:",

min = 1, max = 20, value = 15),

sliderInput("inSlider2", "Slider input 2:",

min = 1, max = 20, value = c(5, 15)),

sliderInput("inSlider3", "Slider input 3:",

min = 1, max = 20, value = c(5, 15)),

dateInput("inDate", "Date input:"),

dateRangeInput("inDateRange", "Date range input:")

)),

column(3,

wellPanel(

checkboxInput("inCheckbox", "Checkbox input",

value = FALSE),

checkboxGroupInput("inCheckboxGroup",

"Checkbox group input:",

c("label 1" = "option1",

"label 2" = "option2")),

radioButtons("inRadio", "Radio buttons:",

c("label 1" = "option1",

"label 2" = "option2")),

selectInput("inSelect", "Select input:",

c("label 1" = "option1",

"label 2" = "option2")),

selectInput("inSelect2", "Select input 2:",

multiple = TRUE,

c("label 1" = "option1",

"label 2" = "option2"))

),

tabsetPanel(id = "inTabset",

tabPanel("panel1", h2("This is the first panel.")),

tabPanel("panel2", h2("This is the second panel."))

)

)

))

首先需要将ui.R和server.R两个代码保存为文件放在同一个文件夹下，然后就可以调用这个app了。

如果变量的值不使用input列表，这里有两种赋值方法：

server = function(input, output, session) {

var1 <- list(a=1, b=2, c=3)

var2 <- reactiveValues(a=1, b=2, c=3)}