Условное срабатывание L oop в РШинах

Question

Я новичок в R и Shiny, и я пытаюсь построить различные сценарии бюджета ios модели ставок в зависимости от стратегии ставок, выбранной пользователем. Для каждой стратегии ставок я написал для l oop, чтобы рассчитать полученную прибыль за заданный промежуток времени. Хотя отдельные циклы работают без проблем за пределами Shiny, внутри приложения мне трудно реализовать их в ответ на ввод пользователя. Вместо того, чтобы получить правильный график, я просто получаю прямую горизонтальную линию на уровне 100, что указывает на то, что петли вообще ничего не сделали.

Я надеялся, что кто-то может мне помочь с этим, потому что это действительно вызывает у меня головную боль. Я прикрепил скрипт, чтобы вы могли пересобрать то, что у меня есть.

library(shiny)
library(dplyr)
library(purrr)
library(tidyverse)
# training data 

Home<-c("A","B","C","D","E","F","G")
Away<-c("H","I","J","K","L","M","N")
Result<-c(1, 0, 0, 1, 1, 0, 1)
OddsHome<-c(1.85, 1.96, 1.90, 1.43, 2.17, 2.22, 2.34)
OddsAway<-c(2.17, 2.04, 2.11, 3.33, 1.85, 1.81, 1.75)
ShotsH<-c(8, 7, 6, 4, 5, 2, 9)
ShotsA<-c(6, 8, 3, 4, 9, 5, 4)

train <-data.frame(Home, Away, OddsHome, OddsAway, ShotsH, ShotsA, Result)
#  test data
Home<-c("A","B","C","D","E","F","G")
Away<-c("H","I","J","K","L","M","N")
OddsHome<-c(1.60, 2.18, 2.20, 3.35, 1.09, 3.07, 2.88)
OddsAway<-c(2.67, 1.85, 1.84, 1.43, 12.11, 1.48, 1.53)
ShotsH<-c(13,5,2,8,9,8,1)
ShotsA<-c(4,7,4,8,6,7,2)
Result<-c(0,0,1,0,1,1,1)

test<-data.frame(Home, Away, OddsHome, OddsAway, ShotsH, ShotsA, Result)

 
ui<- fluidPage(
h1("Germany"),

selectInput(inputId="Model", label= "Prediction Model",
            choice=c("pred1", "pred2")),
selectInput(inputId="Staking", label="Staking Strategy",
            choice= c("Fractional System", "Fixed Amount")),
plotOutput('Odds_compared'),
plotOutput('budget')

)
 
server<- function(input, output,session){
  
# generate linear model for prediction  
observeEvent(input$Model,{
  req(input$Model)
    if (input$Model == "pred1")
    {pred<- glm(Result~ShotsH + ShotsA, data=train, family=binomial)
    }else if (input$Model == "pred2")
     {pred<-glm(Result~ShotsH + ShotsA + OddsHome, data=train, family=binomial)}
    
#mutate new columns with predictions     

    df <- reactive({
      test%>%
      modelr::add_predictions(pred,var="MyProbsH", type="response")%>%
      mutate(MyProbsA=1-MyProbsH)%>%
      mutate(MyOddsH=1/MyProbsH)%>%
      mutate(MyOddsA=1/MyProbsA)%>%
      mutate(profit = 0)%>%
      mutate(budget= 100)%>%
      mutate(fixture=1:n())%>%
      drop_na("fixture") 
    })

#calculate staking strategy    
req(input$Staking)
    if (input$Staking == "FractionalSystem")
    {
      for(i in 2:NROW(df()[1]))
      {
        if(df()[i, 10]<df()[i,3] && df()[i,10]<=2 && df()[i,7]==1)
        {df()[i,12]<-(0.1*df()[i-1,13] *df()[i, 3])-(0.1*df()[i-1, 13])
        df()[i,13]<-df()[i-1,13]+df()[i,12]}
        else if(df()[i, 10]<df()[i,3] && df()[i,10]<=2 && df()[i,7]==0)
        {df()[i,12]<- -0.1*df()[i-1, 13]
        df()[i,13]<-df()[i-1,13]+df()[i,12]}
        else 
        {
          df()[i,13]<-df()[i-1,13]
          df()[i, 12]<-as.numeric(0)}}}
      else if (input$Staking == "FixedAmount")
      {
        for(i in 2:NROW(df()[1]))
        {
          if(df()[i, 10]<df()[i,3] && df()[i,10]<=2 && df()[i,7]==1)
          {df()[i,12]<- 10*df()[i, 3]- 10
          df()[i,13]<-df()[i-1,13]+df()[i,12]}
          else if(df()[i, 10]<df()[i,3] && df()[i,10]<=2 && df()[i,7]==0)
          {df()[i,12]<- -10
          df()[i,13]<-df()[i-1,13]+df()[i,12]}
          else 
          {
            df()[i,13]<-df()[i-1,13]
            df()[i, 12]<-as.numeric(0)}}
      }

#

#create plot
    output$Odds_compared<-renderPlot({plot(df()$MyOddsH, df()$OddsHome)})
    output$budget<-renderPlot({plot(df()$fixture, df()$budget, type="l", col="blue")})

  })
}
shinyApp(ui = ui, server = server)

Answer 1

Я заметил одну вещь: у вас есть пробелы между словами «Fractional System» и «Fixed Amount» - это должно точно совпадать в вашем выражении if.

Кроме того, я бы избегал вложенных reactive выражение внутри вашего observeEvent. Вместо этого вы можете поместить все свои вычисления в выражение reactive.

Возможно, вы также захотите рассмотреть возможность разделения вашего детального моделирования / вычислений на другую функцию.

Сообщите мне, если это работает на вас.

server<- function(input, output, session){

  #perform modeling      
  df <- reactive({
    req(input$Model, input$Staking)
    
    if (input$Model == "pred1")
    {pred<- glm(Result~ShotsH + ShotsA, data=train, family=binomial)
    }else if (input$Model == "pred2")
    {pred<-glm(Result~ShotsH + ShotsA + OddsHome, data=train, family=binomial)}
    
    d <- test %>%
      modelr::add_predictions(pred,var="MyProbsH", type="response")%>%
      mutate(MyProbsA=1-MyProbsH)%>%
      mutate(MyOddsH=1/MyProbsH)%>%
      mutate(MyOddsA=1/MyProbsA)%>%
      mutate(profit = 0)%>%
      mutate(budget= 100)%>%
      mutate(fixture=1:n())%>%
      drop_na("fixture") 
    
    if (input$Staking == "Fractional System")
    {
      for(i in 2:nrow(d[1]))
      {
        if(d[i, 10]<d[i,3] && d[i,10]<=2 && d[i,7]==1)
        {d[i,12]<-(0.1*d[i-1,13] *d[i, 3])-(0.1*d[i-1, 13])
        d[i,13]<-d[i-1,13]+d[i,12]}
        else if(d[i, 10]<d[i,3] && d[i,10]<=2 && d[i,7]==0)
        {d[i,12]<- -0.1*d[i-1, 13]
        d[i,13]<-d[i-1,13]+d[i,12]}
        else 
        {
          d[i,13]<-d[i-1,13]
          d[i, 12]<-as.numeric(0)}}}
    else if (input$Staking == "Fixed Amount")
    {
      for(i in 2:nrow(d[1]))
      {
        if(d[i, 10]<d[i,3] && d[i,10]<=2 && d[i,7]==1)
        {d[i,12]<- 10*d[i, 3]- 10
        d[i,13]<-d[i-1,13]+d[i,12]}
        else if(d[i, 10]<d[i,3] && d[i,10]<=2 && d[i,7]==0)
        {d[i,12]<- -10
        d[i,13]<-d[i-1,13]+d[i,12]}
        else 
        {
          d[i,13]<-d[i-1,13]
          d[i, 12]<-as.numeric(0)}}
    }
    return(d)
  })
  
  #create plots
  output$Odds_compared<-renderPlot({plot(df()$MyOddsH, df()$OddsHome)})
  output$budget<-renderPlot({plot(df()$fixture, df()$budget, type="l", col="blue")})
}