Could you help me tweak the second code below. The first code works normally. In the first I use a database called Test and it does exactly what I want. In the second code notice that I have a df1 database, a function and then it generates a Test database. The result generated by this Test datbase of the second code is exactly the same as the Test database of the first code, the difference is that in the first I am specifying the values of the Test and in the other I use a function to generate. However, in the second code when I run shiny it doesn't show the results, like in the first code, I'd like to adjust that.
First code
library(shiny)
library(shinythemes)
library(dplyr)
library(writexl)
library(tidyverse)
library(lubridate)
Test <- structure(list(date2 = structure(c(18808, 18808, 18809, 18810
), class = "Date"), Category = c("FDE", "ABC", "FDE", "ABC"),
coef = c(4, 1, 6, 1)), row.names = c(NA, 4L), class = "data.frame")
ui <- fluidPage(
shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("",
sidebarLayout(
sidebarPanel(
uiOutput('daterange'),
br()
),
mainPanel(
dataTableOutput('table'),
br(), br(),
downloadButton("dl", "Download")
),
))
))
server <- function(input, output,session) {
data <- reactive(Test)
data_subset <- reactive({
req(input$daterange1)
days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
subset(data(), date2 %in% days)
})
output$daterange <- renderUI({
dateRangeInput("daterange1", "Period you want to see:",
start = min(data()$date2),
end = max(data()$date2))
})
output$table <- renderDataTable({
data_subset()
})
output$dl <- downloadHandler(
filename = function() { "data.xlsx"},
content = function(file) {
writexl::write_xlsx(data_subset(), path = file)
}
)
}
shinyApp(ui = ui, server = server)
Second code
library(shiny)
library(shinythemes)
library(dplyr)
library(writexl)
library(tidyverse)
library(lubridate)
function.test<-function(){
df1 <- structure(
list(date1= c("2021-06-28","2021-06-28","2021-06-28","2021-06-28"),
date2 = c("2021-06-30","2021-06-30","2021-07-01","2021-07-02"),
Category = c("FDE","ABC","FDE","ABC"),
Week= c("Wednesday","Wednesday","Friday","Friday"),
DR1 = c(4,1,6,1),
DR01 = c(4,1,4,4), DR02= c(4,2,6,0),DR03= c(9,5,4,0),
DR04 = c(5,4,3,5),DR05 = c(5,4,5,0),
DR06 = c(2,4,3,5),DR07 = c(2,5,4,0),
DR08 = c(3,4,5,0),DR09 = c(2,3,4,0)),
class = "data.frame", row.names = c(NA, -4L))
return(df1)
}
return_coef <- function(df1, dmda, CategoryChosse) {
x<-df1 %>% select(starts_with("DR0"))
x<-cbind(df1, setNames(df1$DR1 - x, paste0(names(x), "_PV")))
PV<-select(x, date2,Week, Category, DR1, ends_with("PV"))
med<-PV %>%
group_by(Category,Week) %>%
summarize(across(ends_with("PV"), median))
SPV<-df1%>%
inner_join(med, by = c('Category', 'Week')) %>%
mutate(across(matches("^DR0\\d $"), ~.x
get(paste0(cur_column(), '_PV')),
.names = '{col}_{col}_PV')) %>%
select(date1:Category, DR01_DR01_PV:last_col())
SPV<-data.frame(SPV)
mat1 <- df1 %>%
filter(date2 == dmda, Category == CategoryChosse) %>%
select(starts_with("DR0")) %>%
pivot_longer(cols = everything()) %>%
arrange(desc(row_number())) %>%
mutate(cs = cumsum(value)) %>%
filter(cs == 0) %>%
pull(name)
(dropnames <- paste0(mat1,"_",mat1, "_PV"))
SPV <- SPV %>%
filter(date2 == dmda, Category == CategoryChosse) %>%
select(-any_of(dropnames))
datas<-SPV %>%
filter(date2 == ymd(dmda)) %>%
group_by(Category) %>%
summarize(across(starts_with("DR0"), sum)) %>%
pivot_longer(cols= -Category, names_pattern = "DR0(. )", values_to = "val") %>%
mutate(name = readr::parse_number(name))
colnames(datas)[-1]<-c("Days","Numbers")
datas <- datas %>%
group_by(Category) %>%
slice((as.Date(dmda) - min(as.Date(df1$date1) [
df1$Category == first(Category)])):max(Days) 1) %>%
ungroup
mod <- nls(Numbers ~ b1*Days^2 b2,start = list(b1 = 0,b2 = 0),data = datas, algorithm = "port")
as.numeric(coef(mod)[2])
Test<-cbind(df1 %>% select(date2,Category), coef = mapply(return_coef, df1$date2, df1$Category))
}
ui <- fluidPage(
shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("",
sidebarLayout(
sidebarPanel(
uiOutput('daterange'),
br()
),
mainPanel(
dataTableOutput('table'),
br(), br(),
downloadButton("dl", "Download")
),
))
))
server <- function(input, output,session) {
data <- reactive(function.test())
data_subset <- reactive({
req(input$daterange1)
days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
subset(data(), date2 %in% days)
})
output$daterange <- renderUI({
dateRangeInput("daterange1", "Period you want to see:",
start = min(data()$date2),
end = max(data()$date2))
})
output$table <- renderDataTable({
data_subset()
})
output$dl <- downloadHandler(
filename = function() { "data.xlsx"},
content = function(file) {
writexl::write_xlsx(data_subset(), path = file)
}
)
}
shinyApp(ui = ui, server = server)
CodePudding user response：
The problem is in the data you're generating, the dates are strings, not dates. If you change the function.test() definition to the following, it should work:
function.test<-function(){
df1 <- structure(
list(date1= as.Date(c("2021-06-28","2021-06-28","2021-06-28","2021-06-28"), format="%Y-%m-%d"),
date2 = as.Date(c("2021-06-30","2021-06-30","2021-07-01","2021-07-02"), format="%Y-%m-%d"),
Category = c("FDE","ABC","FDE","ABC"),
Week= c("Wednesday","Wednesday","Friday","Friday"),
DR1 = c(4,1,6,1),
DR01 = c(4,1,4,4), DR02= c(4,2,6,0),DR03= c(9,5,4,0),
DR04 = c(5,4,3,5),DR05 = c(5,4,5,0),
DR06 = c(2,4,3,5),DR07 = c(2,5,4,0),
DR08 = c(3,4,5,0),DR09 = c(2,3,4,0)),
class = "data.frame", row.names = c(NA, -4L))
return(df1)
}
Perhaps you know this already, so I apologize if this additional piece isn't helpful, but I always find it useful to use the browse() function to get into the app. If you put the following in your UI:
actionButton("browser", "browser"),
and what's below in your server function:
observeEvent(input$browser,{
browser()
})
It will make a button that allows you to look at the reactive elements in your app. Using the original formulation, you could look at the generated data and its properties:
Browse[1]> data()
# date1 date2 Category Week DR1 DR01 DR02 DR03 DR04 DR05 DR06 DR07 DR08 DR09
# 1 2021-06-28 2021-06-30 FDE Wednesday 4 4 4 9 5 5 2 2 3 2
# 2 2021-06-28 2021-06-30 ABC Wednesday 1 1 2 5 4 4 4 5 4 3
# 3 2021-06-28 2021-07-01 FDE Friday 6 4 6 4 3 5 3 4 5 4
# 4 2021-06-28 2021-07-02 ABC Friday 1 4 0 0 5 0 5 0 0 0
Browse[1]> str(data())
# 'data.frame': 4 obs. of 14 variables:
# $ date1 : chr "2021-06-28" "2021-06-28" "2021-06-28" "2021-06-28"
# $ date2 : chr "2021-06-30" "2021-06-30" "2021-07-01" "2021-07-02"
# $ Category: chr "FDE" "ABC" "FDE" "ABC"
# $ Week : chr "Wednesday" "Wednesday" "Friday" "Friday"
# $ DR1 : num 4 1 6 1
# $ DR01 : num 4 1 4 4
# $ DR02 : num 4 2 6 0
# $ DR03 : num 9 5 4 0
# $ DR04 : num 5 4 3 5
# $ DR05 : num 5 4 5 0
# $ DR06 : num 2 4 3 5
# $ DR07 : num 2 5 4 0
# $ DR08 : num 3 4 5 0
# $ DR09 : num 2 3 4 0
This makes it clear that the date variables are character strings. You could also look at data_subset() to verify that it doesn't have any data:
Browse[1]> data_subset()
# [1] date1 date2 Category Week DR1 DR01 DR02 DR03 DR04 DR05 DR06 DR07 DR08 DR09
# <0 rows> (or 0-length row.names)
This would allow you to do some digging:
Browse[1]> days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
Browse[1]> days
# [1] "2021-06-30" "2021-07-01" "2021-07-02"
Browse[1]> data()$date2 %in% days
# [1] FALSE FALSE FALSE FALSE
Browse[1]> class(days)
# [1] "Date"
Browse[1]> class(data()$date2)
# [1] "character"
This allows you to identify that the date2 variable is a different class than the days vector which is the crux of the problem.
CodePudding user response：
In your function you are calling itself. Also, it is never used on the server side. Therefore, you are getting all the variables in your subset data. Try this
library(shiny)
library(shinythemes)
library(dplyr)
library(writexl)
library(tidyverse)
library(lubridate)
function.test<-function(){
df1 <- structure(
list(date1= c("2021-06-28","2021-06-28","2021-06-28","2021-06-28"),
date2 = c("2021-06-30","2021-06-30","2021-07-01","2021-07-02"),
Category = c("FDE","ABC","FDE","ABC"),
Week= c("Wednesday","Wednesday","Friday","Friday"),
DR1 = c(4,1,6,1),
DR01 = c(4,1,4,4), DR02= c(4,2,6,0),DR03= c(9,5,4,0),
DR04 = c(5,4,3,5),DR05 = c(5,4,5,0),
DR06 = c(2,4,3,5),DR07 = c(2,5,4,0),
DR08 = c(3,4,5,0),DR09 = c(2,3,4,0)),
class = "data.frame", row.names = c(NA, -4L))
return(df1)
}
return_coef <- function(df1, dmda, CategoryChosse) {
x<-df1 %>% select(starts_with("DR0"))
x<-cbind(df1, setNames(df1$DR1 - x, paste0(names(x), "_PV")))
PV<-select(x, date2,Week, Category, DR1, ends_with("PV"))
med<-PV %>%
group_by(Category,Week) %>%
summarize(across(ends_with("PV"), median))
SPV<-df1%>%
inner_join(med, by = c('Category', 'Week')) %>%
mutate(across(matches("^DR0\\d $"), ~.x
get(paste0(cur_column(), '_PV')),
.names = '{col}_{col}_PV')) %>%
select(date1:Category, DR01_DR01_PV:last_col())
SPV<-data.frame(SPV)
mat1 <- df1 %>%
filter(date2 == dmda, Category == CategoryChosse) %>%
select(starts_with("DR0")) %>%
pivot_longer(cols = everything()) %>%
arrange(desc(row_number())) %>%
mutate(cs = cumsum(value)) %>%
filter(cs == 0) %>%
pull(name)
(dropnames <- paste0(mat1,"_",mat1, "_PV"))
SPV <- SPV %>%
filter(date2 == dmda, Category == CategoryChosse) %>%
select(-any_of(dropnames))
datas<-SPV %>%
filter(date2 == ymd(dmda)) %>%
group_by(Category) %>%
summarize(across(starts_with("DR0"), sum)) %>%
pivot_longer(cols= -Category, names_pattern = "DR0(. )", values_to = "val") %>%
mutate(name = readr::parse_number(name))
colnames(datas)[-1]<-c("Days","Numbers")
datas <- datas %>%
group_by(Category) %>%
slice((as.Date(dmda) - min(as.Date(df1$date1) [
df1$Category == first(Category)])):max(Days) 1) %>%
ungroup
mod <- nls(Numbers ~ b1*Days^2 b2,start = list(b1 = 0,b2 = 0),data = datas, algorithm = "port")
return(round(as.numeric(coef(mod)[2])))
# Test<-cbind(df1 %>% select(date2,Category), coef = mapply(return_coef, df1$date2, df1$Category))
}
ui <- fluidPage(
shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("",
sidebarLayout(
sidebarPanel(
uiOutput('daterange'),
br()
),
mainPanel(
dataTableOutput('table'),
br(), br(),
downloadButton("dl", "Download")
),
))
))
server <- function(input, output,session) {
data <- reactive(function.test())
data_subset <- reactive({
req(input$daterange1)
days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
df1 <- subset(data(), as.Date(date2) %in% days)
df2 <- df1 %>% select(date2,Category)
Test <- cbind(df2, coef = apply(df2, 1, function(x) {return_coef(df1,x[1],x[2])}))
Test
})
output$daterange <- renderUI({
dateRangeInput("daterange1", "Period you want to see:",
start = min(data()$date2),
end = max(data()$date2),
min = min(data()$date2),
max = max(data()$date2)
)
})
output$table <- renderDataTable({
data_subset()
})
output$dl <- downloadHandler(
filename = function() { "data.xlsx"},
content = function(file) {
writexl::write_xlsx(data_subset(), path = file)
}
)
}
shinyApp(ui = ui, server = server)
