我正在嘗試編輯我的資料表以將值作為輸入。但是，我想從每個單元格中洗掉數字和滾動條，類似于 Excel/SPSS 單元格。問題在下圖中：
我希望所有單元格看起來大致像這樣，就好像它們是 Excel/SPSS 單元格一樣：
表代碼：
library(shiny)
library(shinydashboard)
library(DT)
library(tidyverse)
library(shinyjs)
header <- dashboardHeader(title = "Dashboard", titleWidth = 300)
sidebar <- dashboardSidebar(
width = 300,
sidebarMenu(
menuItem(
text = "Menu 1",
tabName = "menu1",
icon = icon("chart-line")
)
)
)
body <- dashboardBody(
HTML(
"<head>
<script>
$(function() {
setTimeout(function() {
$('.dt-rigth').dblclick();
}, 1000);
});
</script>
</head>"
),
tabItems(
tabItem(
tabName = "menu1",
titlePanel(
title = HTML(
"<text style='background-color:#008cba; color:#f2f2f2;'>Analysis</text>"
)
),
fluidPage(
column(
id = "menusss1",
width = 12,
column(
id = "correl",
width = 1,
DT::DTOutput("my_datatable"),
actionButton("go", label = "Plot Data")
),
column(
id = "correlplot",
width = 6,
plotOutput("my_plot")
)
)
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
#initialize a blank dataframe
v <- reactiveValues(data = {
data.frame(x = numeric(0) ,y = numeric(0)) %>%
add_row(x = rep(0, 30) ,y = rep(0, 30))
})
#output the datatable based on the dataframe (and make it editable)
output$my_datatable <- DT::renderDataTable({
js <- "table.on('click', 'td', function() {
$(this).dblclick();
});"
DT::datatable(
data = v$data,
editable = TRUE,
rownames = FALSE,
selection = list(mode = 'none'),
callback = JS(js),
options = list(
searching = FALSE,
paging = FALSE,
ordering = FALSE,
info = FALSE,
autoWidth = TRUE
))
})
#when there is any edit to a cell, write that edit to the initial dataframe
#check to make sure it's positive, if not convert
observeEvent(input$my_datatable_cell_edit, {
#get values
info = input$my_datatable_cell_edit
i = as.numeric(info$row)
j = as.numeric(info$col)
k = as.numeric(info$value)
if(k < 0){ #convert to positive if negative
k <- k * -1
}
#write values to reactive
v$data[i,j] <- k
})
#render plot
output$my_plot <- renderPlot({
req(input$go) #require the input button to be non-0 (ie: don't load the plot when the app first loads)
isolate(v$data) %>% #don't react to any changes in the data
ggplot(aes(x,y))
geom_point()
geom_smooth(method = "lm")
})
}
# Run the application
shinyApp(ui = ui, server = server)
編輯
我創建了一個js物件，只需單擊一次并輸入值。請注意，雙擊后，單元格大致是我想要的方式。我試圖添加一個setTimeout()，但無濟于事。我只是想讓它填充更大的空間而不是滾動。這邊走：
就好像它是 Excel/SPSS 或類似的：
uj5u.com熱心網友回復：
首先，要洗掉單元格編輯時的向上/向下箭頭和雙擊單元格時出現的（藍色）內邊框，應在ui中添加自定義css，如下所示：
tags$style(HTML("table.dataTable tr td input:focus {outline: none; background: none; border:none;};
table.dataTable tr td input[type=number]::-webkit-inner-spin-button,
input[type=number]::-webkit-outer-spin-button {
-webkit-appearance: none;
margin: 0;
}"))
然后，要洗掉數字，您可以簡單地用 NAs 而不是零初始化資料幀：
v <- reactiveValues(data = {
data.frame(x = NA ,y = NA) %>%
add_row(x = rep(NA, 30) ,y = rep(NA, 30))
})
要在用戶編輯單元格中的值時在單元格周圍添加綠色邊框，應添加以下 JS 代碼：
callback = JS("$('table').on('dblclick', 'td', function() {
$(this).css('border', '1px solid green');
});")
把所有這些放在一起：
library(shiny)
library(shinydashboard)
library(DT)
library(tidyverse)
header <- dashboardHeader(title = "Dashboard", titleWidth = 300)
sidebar <- dashboardSidebar(
width = 300,
sidebarMenu(
menuItem(
text = "Menu 1",
tabName = "menuid1",
icon = icon("chart-line")))
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = "menuid1",
titlePanel(
title = HTML("<text style='background-color:#008cba; color:#f2f2f2;'>Analysis</text>")),
fluidPage(
tags$style(HTML("table.dataTable tr td input:focus {outline: none; background: none; border:none;};
table.dataTable tr td input[type=number]::-webkit-inner-spin-button,
input[type=number]::-webkit-outer-spin-button {
-webkit-appearance: none;
margin: 0;
};")),
column(
id = "meuprimeiromenuid1",
width = 12,
column(
id = "correl",
width = 1,
DT::DTOutput("my_datatable"),
actionButton("go", label = "Plot Data")),
column(
id = "correlplot",
width = 6,
plotOutput("my_plot"))
))
))
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
#initialize a blank dataframe
v <- reactiveValues(data = {
data.frame(x = NA ,y = NA) %>%
add_row(x = rep(NA, 30) ,y = rep(NA, 30))
})
callback = JS("$('table').on('dblclick', 'td', function() {
$(this).css('border', '1px solid green');
});")
#output the datatable based on the dataframe (and make it editable)
output$my_datatable <- DT::renderDataTable({
DT::datatable(
data = v$data,
editable = TRUE,
rownames = FALSE,
selection = list(mode = 'none'),
callback = callback,
options = list(
searching = FALSE,
paging = FALSE,
ordering = FALSE,
info = FALSE,
autoWidth = TRUE
))
})
#when there is any edit to a cell, write that edit to the initial dataframe
#check to make sure it's positive, if not convert
observeEvent(input$my_datatable_cell_edit, {
#get values
info = input$my_datatable_cell_edit
i = as.numeric(info$row)
j = as.numeric(info$col) 1
k = as.numeric(info$value)
if (!is.na(k) & k < 0) { #convert to positive if negative
k <- k * -1
}
#write values to reactive
v$data[i,j] <- k
})
#render plot
output$my_plot <- renderPlot({
# browser()
req(input$go) #require the input button to be non-0 (ie: don't load the plot when the app first loads)
isolate(v$data) %>% #don't react to any changes in the data
drop_na() %>%
ggplot(aes(x,y))
geom_point()
geom_smooth(method = "lm")
})
}
# Run the application
shinyApp(ui = ui, server = server)
此外，這里還有兩個注意事項： (1) 在單元格編輯觀察事件中，j考慮到列計數從 0 開始并且行名被禁用，關于列 ( ) 的變數應該增加 1。(2) 鑒于現在資料框已通過NA添加適當的單元格編輯檢查來初始化其值，并且在創建/渲染繪圖時可能需要。例如，我添加了一個命令，用于在創建繪圖 ( ) 之前洗掉包含 NA 值的任何行drop_na。
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/512283.html