Блог

#r #shiny

#r #блестящий

Вопрос:

 library(shiny) library(shinythemes) library(dplyr) library(tidyverse) library(lubridate) library(shinyWidgets)  function.testlt;-function(){    df1 lt;- structure(  list(date1= c("2021-06-26","2021-06-26","2021-06-26","2021-06-26"),  date2 = c("2021-06-27","2021-07-01","2021-07-02","2021-07-03"),  Category = c("ABC","ABC","ABC","ABC"),  Week= c("Saturday","Wednesday","Thurday","Saturday"),  DR1 = c(5,4,1,1),  DR01 = c(8,4,1,0), DR02= c(7,4,2,0),DR03= c(6,9,5,0),  DR04 = c(5,5,4,0),DR05 = c(5,5,4,0),DR06 = c(7,5,4,0),DR07 = c(2,5,4,0),DR08 = c(2,5,4,0)),  class = "data.frame", row.names = c(NA, -4L))    return(df1)   }  f1 lt;- function(df1, dmda, CategoryChosse, plot = FALSE, var1, var2, gnum=0, graf=1) {    xlt;-df1 %gt;% select(starts_with("DR0"))    xlt;-cbind(df1, setNames(df1$DR1 - x, paste0(names(x), "_PV")))  PVlt;-select(x, date2,Week, Category, DR1, ends_with("PV"))    medlt;-PV %gt;%  group_by(Category,Week) %gt;%  dplyr::summarize(dplyr::across(ends_with("PV"), median))    SPVlt;-df1%gt;%  inner_join(med, by = c('Category', 'Week')) %gt;%  mutate(across(matches("^DR0\d $"), ~.x     get(paste0(cur_column(), '_PV')),  .names = '{col}_{col}_PV')) %gt;%  select(date1:Category, DR01_DR01_PV:last_col())    SPVlt;-data.frame(SPV)    mat1 lt;- df1 %gt;%  dplyr::filter(date2 == dmda, Category == CategoryChosse) %gt;%  select(starts_with("DR0")) %gt;%  pivot_longer(cols = everything()) %gt;%  arrange(desc(row_number())) %gt;%  mutate(cs = cumsum(value)) %gt;%  dplyr::filter(cs == 0) %gt;%  pull(name)    (dropnames lt;- paste0(mat1,"_",mat1, "_PV"))    SPV lt;- SPV %gt;%  filter(date2 == dmda, Category == CategoryChosse) %gt;%  select(-any_of(dropnames))    if(length(grep("DR0", names(SPV))) == 0) {  SPV[head(mat1,10)] lt;- NA_real_  }    datas lt;-SPV %gt;%  dplyr::filter(date2 == ymd(dmda)) %gt;%  group_by(Category) %gt;%  dplyr::summarize(dplyr::across(starts_with("DR0"), sum)) %gt;%  pivot_longer(cols= -Category, names_pattern = "DR0(. )", values_to = "val") %gt;%  mutate(name = readr::parse_number(name))  colnames(datas)[-1]lt;-c(var1,var2)  datas$days lt;- datas[[as.name(var1)]]  datas$numbers lt;- datas[[as.name(var2)]]    datas lt;- datas %gt;%   group_by(Category) %gt;%   slice((as.Date(dmda) - min(as.Date(df1$date1) [  df1$Category == first(Category)])):max(days) 1) %gt;%  ungroup    mlt;-df1 %gt;%  group_by(Category,Week) %gt;%  dplyr::summarize(dplyr::across(starts_with("DR1"), mean))    mlt;-subset(m, Week == df1$Week[match(ymd(dmda), ymd(df1$date2))] amp; Category == CategoryChosse)$DR1    if (nrow(datas)lt;=2){  vallt;-as.numeric(m)  }    else{  mod lt;- nls(numbers ~ b1*days^2 b2,start = list(b1 = 0,b2 = 0),data = datas, algorithm = "port")  coeflt;-coef(mod)[2]  vallt;-as.numeric(coef(mod)[2])  }      if(plot){    maxrange lt;- range(0, datas$numbers, na.rm = TRUE)  maxrange[2] lt;- maxrange[2]   10     if (gnum) maxrange[2] lt;- maxrange[2]   40   maxlt;-max(0, datas$days, na.rm = TRUE) 1  limx = c(0,max)  limy = c(0,maxrange[2])  if (graf==1){  if (nrow(datas)lt;=2) leg = round(m,1) else leg = round(coef,1)  titl = "The number is:"  }else if (graf==2){  if (nrow(datas)lt;=2) leg = paste('US

 round_0 lt;- partial(round, digits = 0) round_1 lt;- partial(round, digits = 1)  

 f1 lt;- function(df1, dmda, CategoryChosse, plot = FALSE, var1, var2, gnum=0, graf=1, fr) {    xlt;-df1 %gt;% select(starts_with("DR0"))    xlt;-cbind(df1, setNames(df1$DR1 - x, paste0(names(x), "_PV")))  PVlt;-select(x, date2,Week, Category, DR1, ends_with("PV"))    medlt;-PV %gt;%  group_by(Category,Week) %gt;%  dplyr::summarize(dplyr::across(ends_with("PV"), median))    SPVlt;-df1%gt;%  inner_join(med, by = c('Category', 'Week')) %gt;%  mutate(across(matches("^DR0\d $"), ~.x     get(paste0(cur_column(), '_PV')),  .names = '{col}_{col}_PV')) %gt;%  select(date1:Category, DR01_DR01_PV:last_col())    SPVlt;-data.frame(SPV)    mat1 lt;- df1 %gt;%  dplyr::filter(date2 == dmda, Category == CategoryChosse) %gt;%  select(starts_with("DR0")) %gt;%  pivot_longer(cols = everything()) %gt;%  arrange(desc(row_number())) %gt;%  mutate(cs = cumsum(value)) %gt;%  dplyr::filter(cs == 0) %gt;%  pull(name)    (dropnames lt;- paste0(mat1,"_",mat1, "_PV"))    SPV lt;- SPV %gt;%  filter(date2 == dmda, Category == CategoryChosse) %gt;%  select(-any_of(dropnames))    if(length(grep("DR0", names(SPV))) == 0) {  SPV[head(mat1,10)] lt;- NA_real_  }    datas lt;-SPV %gt;%  dplyr::filter(date2 == ymd(dmda)) %gt;%  group_by(Category) %gt;%  dplyr::summarize(dplyr::across(starts_with("DR0"), sum)) %gt;%  pivot_longer(cols= -Category, names_pattern = "DR0(. )", values_to = "val") %gt;%  mutate(name = readr::parse_number(name))  colnames(datas)[-1]lt;-c(var1,var2)  datas$days lt;- datas[[as.name(var1)]]  datas$numbers lt;- datas[[as.name(var2)]]    datas lt;- datas %gt;%   group_by(Category) %gt;%   slice((as.Date(dmda) - min(as.Date(df1$date1) [  df1$Category == first(Category)])):max(days) 1) %gt;%  ungroup    mlt;-df1 %gt;%  group_by(Category,Week) %gt;%  dplyr::summarize(dplyr::across(starts_with("DR1"), mean))    mlt;-subset(m, Week == df1$Week[match(ymd(dmda), ymd(df1$date2))] amp; Category == CategoryChosse)$DR1    if (nrow(datas)lt;=2){  vallt;-as.numeric(m)  }    else{  mod lt;- nls(numbers ~ b1*days^2 b2,start = list(b1 = 0,b2 = 0),data = datas, algorithm = "port")  coeflt;-coef(mod)[2]  vallt;-as.numeric(coef(mod)[2])  }      if(plot){    maxrange lt;- range(0, datas$numbers, na.rm = TRUE)  maxrange[2] lt;- maxrange[2]   10     if (gnum) maxrange[2] lt;- maxrange[2]   40   maxlt;-max(0, datas$days, na.rm = TRUE) 1  limx = c(0,max)  limy = c(0,maxrange[2])  if (graf==1){  if (nrow(datas)lt;=2) leg = fr(m) else leg = fr(coef)  titl = "The number is:"  }else if (graf==2){  if (nrow(datas)lt;=2) leg = paste('US

Наконец, внутри сервера измените вывод$graph*.

 output$graph lt;- renderPlot({  req(input$date2,input$code)  var1 = "Days"  var2 = "Numbers"  f1(data(),as.character(input$date2),as.character(input$code),var1,var2,plot=TRUE, graf=1, fr = round_0)  })    output$graph2 lt;- renderPlot({  req(input$date2,input$code)  var1 = "Reserv"  var2 = "Weekdays"  f1(data(),as.character(input$date2),as.character(input$code),var1,var2,1,plot=TRUE, graf=2, fr = round_1)  })  
В качестве альтернативы  floor()  округлим до наименьшего целого числа.

,round(coef,1)) titl = " The value is:" } plot(numbers ~ days, xlim= limx, ylim= limy, xlab = var1, ylab=var2, xaxs='i',data = datas,main = paste0(dmda, "-", CategoryChosse)) legend("topright", legend= leg,title=titl,title.col = "black", cex = 1.2) if (nrow(datas)lt;=2){ abline(h=m,lwd=2) points(0, m, col = "red", pch = 19, cex = 2, xpd = TRUE) text(.1,m .5, round(m,1), cex=1.1,pos=4,offset =1,col="black") } else{ new.data lt;- data.frame(days = with(datas, seq(min(days),max(days),len = 45))) new.data lt;- rbind(0, new.data) lines(new.data$days,predict(mod,newdata = new.data),lwd=2) points(0, coef, col="red",pch=19,cex = 2,xpd=TRUE) text(.99,coef 1,max(0, round(coef,1)), cex=1.1,pos=4,offset =1,col="black") } } return(val) } ui lt;- fluidPage( shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE, br(), tabPanel("", sidebarLayout( sidebarPanel( uiOutput("date"), uiOutput("mycode")), mainPanel( tabsetPanel( tabPanel("Graph1", plotOutput("graph",width = "100%", height = "600")), tabPanel("Graph2", plotOutput("graph2",width = "100%", height = "600")) ) )) ))) server lt;- function(input, output,session) { data lt;- reactive(function.test()) output$date lt;- renderUI({ req(data()) all_dates lt;- seq(as.Date('2021-01-01'), as.Date('2021-01-15'), by = "day") disabled lt;- as.Date(setdiff(all_dates, as.Date(data()$date2)), origin = "1970-01-01") dateInput(input = "date2", label = h4("Choose"), min = min(data()$date2), max = max(data()$date2), value = NA, datesdisabled = disabled) }) output$mycode lt;- renderUI({ req(input$date2) df1 lt;- data() df2 lt;- df1[as.Date(df1$date2) %in% input$date2,] selectInput("code", label = h4("Category"),choices=unique(df2$Category)) }) output$graph lt;- renderPlot({ req(input$date2,input$code) var1 = "Days" var2 = "Numbers" f1(data(),as.character(input$date2),as.character(input$code),var1,var2,plot=TRUE, graf=1) }) output$graph2 lt;- renderPlot({ req(input$date2,input$code) var1 = "Reserv" var2 = "Weekdays" f1(data(),as.character(input$date2),as.character(input$code),var1,var2,1,plot=TRUE, graf=2) }) } shinyApp(ui = ui, server = server)

Ответ №1:

Комментарии:

1. Спасибо за ответ, какова функция библиотеки partial ? Когда я запускаю round_0 , он появляется: could not find function "partial"

2. partial находится в purrr библиотеке, вы можете загрузить его с помощью library(tidyverse) или library(purrr) .

,fr(coef)) titl = » The value is:» } plot(numbers ~ days, xlim= limx, ylim= limy, xlab = var1, ylab=var2, xaxs=’i’,data = datas,main = paste0(dmda, «-«, CategoryChosse)) legend(«topright», legend= leg,title=titl,title.col = «black», cex = 1.2) if (nrow(datas)lt;=2){ abline(h=m,lwd=2) points(0, m, col = «red», pch = 19, cex = 2, xpd = TRUE) text(.1,m .5, fr(m), cex=1.1,pos=4,offset =1,col=»black») } else{ new.data lt;- data.frame(days = with(datas, seq(min(days),max(days),len = 45))) new.data lt;- rbind(0, new.data) lines(new.data$days,predict(mod,newdata = new.data),lwd=2) points(0, coef, col=»red»,pch=19,cex = 2,xpd=TRUE) text(.99,coef 1,max(0, fr(coef)), cex=1.1,pos=4,offset =1,col=»black») } } return(val) }

Наконец, внутри сервера измените вывод$graph*.

В качестве альтернативы floor() округлим до наименьшего целого числа.

Комментарии:

1. Спасибо за ответ, какова функция библиотеки partial ? Когда я запускаю round_0 , он появляется: could not find function "partial"

2. partial находится в purrr библиотеке, вы можете загрузить его с помощью library(tidyverse) или library(purrr) .

, round(m,1)) else leg = paste(‘US

Ответ №1:

Комментарии:

1. Спасибо за ответ, какова функция библиотеки partial ? Когда я запускаю round_0 , он появляется: could not find function "partial"

2. partial находится в purrr библиотеке, вы можете загрузить его с помощью library(tidyverse) или library(purrr) .

,round(coef,1)) titl = » The value is:» } plot(numbers ~ days, xlim= limx, ylim= limy, xlab = var1, ylab=var2, xaxs=’i’,data = datas,main = paste0(dmda, «-«, CategoryChosse)) legend(«topright», legend= leg,title=titl,title.col = «black», cex = 1.2) if (nrow(datas)lt;=2){ abline(h=m,lwd=2) points(0, m, col = «red», pch = 19, cex = 2, xpd = TRUE) text(.1,m .5, round(m,1), cex=1.1,pos=4,offset =1,col=»black») } else{ new.data lt;- data.frame(days = with(datas, seq(min(days),max(days),len = 45))) new.data lt;- rbind(0, new.data) lines(new.data$days,predict(mod,newdata = new.data),lwd=2) points(0, coef, col=»red»,pch=19,cex = 2,xpd=TRUE) text(.99,coef 1,max(0, round(coef,1)), cex=1.1,pos=4,offset =1,col=»black») } } return(val) } ui lt;- fluidPage( shiny::navbarPage(theme = shinytheme(«flatly»), collapsible = TRUE, br(), tabPanel(«», sidebarLayout( sidebarPanel( uiOutput(«date»), uiOutput(«mycode»)), mainPanel( tabsetPanel( tabPanel(«Graph1», plotOutput(«graph»,width = «100%», height = «600»)), tabPanel(«Graph2», plotOutput(«graph2»,width = «100%», height = «600»)) ) )) ))) server lt;- function(input, output,session) { data lt;- reactive(function.test()) output$date lt;- renderUI({ req(data()) all_dates lt;- seq(as.Date(‘2021-01-01’), as.Date(‘2021-01-15’), by = «day») disabled lt;- as.Date(setdiff(all_dates, as.Date(data()$date2)), origin = «1970-01-01») dateInput(input = «date2», label = h4(«Choose»), min = min(data()$date2), max = max(data()$date2), value = NA, datesdisabled = disabled) }) output$mycode lt;- renderUI({ req(input$date2) df1 lt;- data() df2 lt;- df1[as.Date(df1$date2) %in% input$date2,] selectInput(«code», label = h4(«Category»),choices=unique(df2$Category)) }) output$graph lt;- renderPlot({ req(input$date2,input$code) var1 = «Days» var2 = «Numbers» f1(data(),as.character(input$date2),as.character(input$code),var1,var2,plot=TRUE, graf=1) }) output$graph2 lt;- renderPlot({ req(input$date2,input$code) var1 = «Reserv» var2 = «Weekdays» f1(data(),as.character(input$date2),as.character(input$code),var1,var2,1,plot=TRUE, graf=2) }) } shinyApp(ui = ui, server = server)

Ответ №1:

Комментарии:

1. Спасибо за ответ, какова функция библиотеки partial ? Когда я запускаю round_0 , он появляется: could not find function "partial"

2. partial находится в purrr библиотеке, вы можете загрузить его с помощью library(tidyverse) или library(purrr) .