r语言 - 计算在shiny范围内的数据的百分比

Question

我有一个这样的数据库，但是更大。

Indicea<-c(1,2,3,5,3,1,3,5,3,6,NA,2,1,1,3,2)
Indiced<-c(0.1,0.5,06,032,0.1,0.25,0.23,0.12,0.15,NA,0.25,0.45,1.0,0.5,0.26,0.45)
Especialidad<-c("gato","gato","gato","perro","perro","perro","perro",
"buho","buho","buho","buho","tigre","tigre","tigre",NA,"tigre")
Fecha<-c("01/03/2020","02/03/2020","03/03/2020","04/03/2020",
"05/03/2020","06/03/2020","07/03/2020","08/03/2020",
"09/03/2020","10/03/2020","11/03/2020","12/03/2020",
"13/03/2020","14/03/2020","15/03/2020","15/03/2020")
data<-dataframe(Indicea, Indiceb,Indicec,Indiced,Especialidad,Fecha)

我的ui是完美的，这是我的服务的一小部分，我有一个幻灯片输出，根据列的变化。我需要做一个表，按" specialidad "分组并计算sliderInput中所选数字在范围内出现的次数及其所代表的百分比

output$Rango<-renderUI({
req(input$SeleccioneIndice)
minn <- min(BD9.3()[,input$SeleccioneIndice], na.rm = TRUE)
maxx <- max(BD9.3()[,input$SeleccioneIndice], na.rm = TRUE)
sliderInput("Rango",label = "Seleccione un rango", min = minn, 
max=maxx, value=c(minn,maxx))
})
BD9.5<-reactive({
BD9.4<-BD9.3()
BD9.4$Intervalo<-NA
BD9.4$Intervalo<-replace(BD9.4$Intervalo,BD9.4[,which
(names(BD9.4)==input$SeleccioneIndice)]>=as.numeric(minn),
"Correcto")
BD9.4$Intervalo<-replace(BD9.4$Intervalo,BD9.4[,which
(names(BD9.4)==input$SeleccioneIndice)]<=as.numeric(maxx), 
"Fallo") 
BD9.4$Intervalo<-replace(BD9.4$Intervalo,BD9.4[,which
(names(BD9.4)==input$SeleccioneIndice )]<=as.numeric(minn),  
"Correcto")
BD9.4$Intervalo<-replace(BD9.4$Intervalo,BD9.4[,which
(names(BD9.4)==input$SeleccioneIndice)]>=as.numeric(maxx),
"Fallo")
BD9.6<-as.data.frame(table(BD9.4$specialty.name,BD9.4$Intervalo))
names(BDa4)<-c("Especialidad","Intervalo","Total")
BD9.6$Porcentaje<-NA
for(i in levels(factor(BD9.6$Especialidad))){
BD9.6[BD9.6$Especialidad==i,]$Porcentaje=round((
BD9.6[BD9.6$Especialidad==i,]$Total/sum
(BD9.6[BD9.6$Especialidad==i,]$Total))*100,2)
}
BD9.6 <- arrange(BD9.6, Especialidad, Cumplimiento) 
BD9.6

output$summary9<-renderPrint({
BD9.6%>%
filtro<-subset(BD9.6, Cumplimiento == "Correcto")
print(arrange(filtro,-Porcentaje))
})

也许我想多了，无论如何，请帮助我。

Answer 1

我想这应该能满足你的需要。它可能需要一些调整，因为我不是100%确定你的百分比应该是多少。在未来，请发布一个完整的MRE，以便有人可以帮助你。

library(tidyr)
Indicea<-c(1,2,3,5,3,1,3,5,3,6,NA,2,1,1,3,2)
Indiceb<-c(12,15,12,14,13,16,14,13,15,12,14,13,NA,13,11,12)
Indicec<-c(100,NA,120,154,125,201,102,150,102,105,140,156,118,113,175,189)
Especialidad<-c("gato","gato","gato","perro","perro","perro","perro",
"buho","buho","buho","buho","tigre","tigre","tigre",NA,"tigre")
Indiced<-c(0.1,0.5,0.6,0.32,0.1,0.25,0.23,0.12,0.15,NA,0.25,0.45,1.0,0.5,0.26,0.45)
Fecha<-c("01/03/2020","02/03/2020","03/03/2020","04/03/2020",
"05/03/2020","06/03/2020","07/03/2020","08/03/2020",
"09/03/2020","10/03/2020","11/03/2020","12/03/2020",
"13/03/2020","14/03/2020","15/03/2020","15/03/2020")
data<-data.frame(Indicea, Indiceb,Indicec,Indiced,Especialidad,Fecha)
ui <- fluidPage(
tabItem("IndicesI",
tabsetPanel(# position= "left",
tabPanel("Indices de ingreso", icon = icon("file-medical-alt"),
sidebarLayout(sidebarPanel(
uiOutput("SeleccioneEspecialidad2"),
uiOutput("SeleccioneIndice"),
uiOutput("Rango"),
uiOutput("RandeDatedI"),
checkboxInput("Todas","Seleccione Todas/Ninguna", value = FALSE)
),
mainPanel(
#plotOutput("lineplotI"),
DTOutput("t1"),
DTOutput("summary9")
)))
)
)
)
server <- function(input, output, session) {
output$SeleccioneEspecialidad2<-renderUI({
choices <- na.omit(data$Especialidad)
selectInput("SeleccioneEspecialidad2", "Seleccione Especialidad",
choices=choices, multiple = T, selected = TRUE )
})
output$SeleccioneIndice <-renderUI({
selectInput("SeleccioneIndice", "Seleccione Indice", choices=
c("Ments"="Indicea",
"Fragilidad"="Indiceb",
"ElixhauserAHRQ"="Indicec",
"ElixhauserVanWalraven"="Indiced"))
})
BD9<-reactive({
req(input$SeleccioneEspecialidad2)
data$Fecha <- as.Date(data$Fecha,format= "%d/%m/%y")
data %>%
filter(Especialidad %in% input$SeleccioneEspecialidad2 )
})

BD91<-reactive({
req(BD9(),input$SeleccioneIndice)

df <- BD9() %>% drop_na(input$SeleccioneIndice, Especialidad)
df
})
output$t11 <- renderDT(datatable(BD91()))

FechaI<-reactive({
BD9.1<-BD9()
unique(BD9()$Fecha)
})
output$RandeDatedI <-renderUI({
req(FechaI())
mymin <- min(FechaI(),na.rm=T)
mymax <- max(FechaI(),na.rm=T)
dateRangeInput('dateRangeI',
label = 'Seleccione un rango',
start = mymin, end = mymax,
min = mymin, max = mymax
)
})
BD9.3<-reactive({
req(input$dateRangeI, BD9())
BD9.2<-BD9()
BD9.2 %>%
filter(Fecha >= input$dateRangeI[1] & Fecha <= input$dateRangeI[2])
})
output$Rango<-renderUI({
req(input$SeleccioneIndice,BD9.3())
minn <- min(BD9.3()[,input$SeleccioneIndice], na.rm = TRUE)
maxx <- max(BD9.3()[,input$SeleccioneIndice], na.rm = TRUE)
sliderInput("Rango",label = "Seleccione un rango", min = minn, max=maxx,
value=c(minn,maxx))
})
BD9.5<-reactive({
req(BD9.3(),input$SeleccioneIndice,input$SeleccioneEspecialidad2,input$Rango)
BD9.4<-BD9.3()
BD9.4 %>%
filter(.data[[input$SeleccioneIndice]] >= input$Rango[1]  &
.data[[input$SeleccioneIndice]] <= input$Rango[2]) 
})

BD96 <- reactive({
req(BD9.5(),BD91())
dfsub <- BD9.5() %>% count(Especialidad)
df1 <- BD91() %>% count(Especialidad) %>% rename(den=n)
df3 <- dplyr::left_join(dfsub, df1, by=c("Especialidad"),all=TRUE) %>% mutate(Porcentaje = (n/den)*100) %>% select(1,2,4)
df3
})
output$t1 <- renderDT(datatable(BD9.5()))

output$summary9<-renderDT({
datatable(BD96(), class = 'cell-border stripe', options = list(
order = list(list(3, 'desc'))))
})
}
shinyApp(ui, server)