inst/shiny/server.R

In olssol/tburden: Tumor burden based treatment effect evaluation

options(shiny.maxRequestSize = 200 * 1024 ^ 2)
require(ggplot2)
require(plotly)


shinyServer(function(input, output, session) {

    source("design_ui.R", local = TRUE);

    userLog       <- reactiveValues();
    userLog$data  <- NULL;

    ##--------------------------------------
    ##---------main-------------------------
    ##--------------------------------------
    output$mainpage <- renderUI({
       tab_main()
    })

    ##--------------------------------------
    ##---------exit-------------------------
    ##--------------------------------------
    observeEvent(input$close, {
        stopApp()})

    ##--------------------------------------
    ##---------data-------------------------
    ##--------------------------------------
    output$dt_surv <- DT::renderDataTable({
        dta <- get_data()

        if (is.null(dta))
            return(NULL)

        dta$dat_surv %>%
            select(SUBJID, ARM, RANDT, PFS_EVENT,
                   PFS_DAYS, OS_EVENT, OS_DAYS, PFS, OR)
    },
    selection = 'single',
    server    = TRUE,
    options   = list())

    output$dt_tb <- DT::renderDataTable({
        dat <- get_cur_tb()
        if (is.null(dat))
            return(NULL)

        dat %>%
            select(SUBJID, VISIT, DAY, PCHG)
    }, options = list(dom = 'pt'))

    output$dt_cov <- DT::renderDataTable({
        dat <- get_data()
        if (is.null(dat))
            return(NULL)

        id <- get_cur_id()
        if (is.null(id))
            return(NULL)

        dat$dat_surv %>%
            filter(SUBJID == id) %>%
            select(SUBJID, ARM, BASE, AGE, SEX, STRATA1, P1TERTL, PFS, PFS_DAYS)
    }, options = list(dom = 't'))

    output$dt_impsurv <- DT::renderDataTable({
        get_cur_imp_surv()
    },
    selection = 'single',
    server    = TRUE,
    options = list(dom = 't'))


    ##--------------------------------------
    ##---------UI------------------------
    ##--------------------------------------
    output$uiChkPwrXyTest <- renderUI({
        dat <- get_pwr_xy_data()

        if (is.null(dat))
            return(NULL)

        tests <- unique(dat$Test)
        checkboxGroupInput("inChkPwrXyTest",
                           "Select Test",
                           choices  = tests,
                           selected = tests)
    })

    output$uiChkPwrSubTest <- renderUI({
        dat <- get_pwr_sub_data()

        if (is.null(dat))
            return(NULL)

        tests <- unique(dat$Test)
        checkboxGroupInput("inChkPwrSubTest",
                           "Select Test",
                           choices  = tests,
                           selected = tests)
    })

    output$uiChkCurveGrp <- renderUI({
        dat <- get_plot_curves()$dat_ref

        if (is.null(dat))
            return(NULL)

        groups <- unique(dat$Overlay_Group)
        checkboxGroupInput("inChkCurveGrp",
                           "Select Group",
                           inline   = TRUE,
                           choices  = groups,
                           selected = groups)
    })

    ## random subset curves
    output$uiSubCurvSize <- renderUI({
        dta <- get_pwr_sub_dta()
        if (is.null(dta))
            return(NULL)

        selectInput("inSubSize",
                    "Size of Subset",
                    choices = unique(dta$size))
    })

    ## slider of pfs id
    output$uiSliderPfsId <- renderUI({
        dta <- get_pfs_id()
        if (is.null(dta))
            return(NULL)

        sliderInput("inPfsID",
                    "Ordered PFS Events",
                    value = c(1, nrow(dta)),
                    min = 1, max = nrow(dta), step = 1)
    })

    ##--------------------------------------
    ##---------PLOTS------------------------
    ##--------------------------------------

    ## plot AUC
    output$pltPt <- renderPlot({
        rst <- get_cur_plt()

        if (is.null(rst))
            return(NULL)

        rst
    })

    output$pltTb <- renderPlot({
        dta <- get_data()

        if (is.null(dta))
            return(NULL)

        dat_tb <- dta$dat_tb
        id     <- get_cur_id()

        tb_plt_tb(dat_tb, id,
                  by_var = input$inByvar, sub_p = input$inTbSub)
    })

    ## plot AUC Density
    output$pltAUC <- renderPlot({
        plot_auc_density()
    })

    ## imputed survival
    output$pltImpPFS <- renderPlot({
        dta <- get_data()

        if (is.null(dta))
            return(NULL)

        tb_plt_km_imp(dta$imp_surv, dta$dat_surv,
                      inx_imp = input$inImpInx, type = "PFS",
                      by_var = input$inByvar,
                      lim_x  = input$inSurvXlim,
                      censor = FALSE)
    })

    output$pltImpOS <- renderPlot({
        dta <- get_data()

        if (is.null(dta))
            return(NULL)

        tb_plt_km_imp(dta$imp_surv, dta$dat_surv,
                      inx_imp = input$inImpInx,
                      type   = "OS",
                      by_var = input$inByvar,
                      lim_x  = input$inSurvXlim,
                      censor = FALSE)
    })

    output$pltCorr <- renderPlot({
        dta <- get_data()

        if (is.null(dta))
            return(NULL)

        tb_plt_estimate(dta$estimate,
                        var1 = input$inCorX,
                        var2 = input$inCorY)
    })

    ## observed survival
    output$pltPFS <- renderPlotly({
        dta <- get_study_data()

        if (is.null(dta))
            return(NULL)

        dat_surv <- get_filter(dta$dat_surv,
                               get_filtered_id())

        rst <- tb_plt_km(dat_surv, "PFS",
                         by_var = input$inByvar2,
                         censor = FALSE)
        ggplotly(rst)
    })

    output$pltOS <- renderPlotly({
        dta <- get_study_data()

        if (is.null(dta))
            return(NULL)

        dat_surv <- get_filter(dta$dat_surv,
                               get_filtered_id())

        rst <- tb_plt_km(dat_surv, "OS",
                         by_var = input$inByvar2,
                         censor = FALSE)
        ggplotly(rst)
    })

    output$pltFU <- renderPlotly({
        dta <- get_study_data()
        if (is.null(dta))
            return(NULL)

        dat_surv <- get_filter(dta$dat_surv,
                               get_filtered_id())
        rst <- tb_plt_fu(dat_surv,
                         by_var   = input$inByvar2,
                         date_dbl = dta$date_dbl)
        ggplotly(rst)
    })

    output$pltFUid <- renderPlotly({
        dta <- get_study_data()
        if (is.null(dta))
            return(NULL)

        id <- get_cur_id()
        if (is.null(id))
            return(NULL)

        rst <- tb_plt_fu(dta$dat_surv,
                         date_dbl = dta$date_dbl,
                         id       = id)
        ggplotly(rst)
    })

    ##--------------------------------------
    ##---------PLOTS CURVES-----------------
    ##--------------------------------------

    output$pltCurves <- renderPlotly({
        rst <- get_plot_curves()$plot
        rst <- rst +
            geom_hline(yintercept = 0, lty = 2, col = "black") +
            coord_cartesian(ylim = c(input$inYlimLB, input$inYlimUB))

        ggplotly(rst)
    })

    ## reference curves overlay
    output$pltCurvesOverlay <- renderPlotly({
        rst <- plot_curves_overlay()

        if (is.null(rst))
            return(NULL)

        rst <- rst +
            geom_hline(yintercept = 0, lty = 2, col = "black") +
            coord_cartesian(ylim = c(input$inYlimLB, input$inYlimUB))

        ggplotly(rst)
    })

    ## subset curves
    output$pltRndSubCurve <- renderPlotly({
        rst <- plot_subset_curve()

        if (is.null(rst))
            return(NULL)

        rst <- rst +
            geom_hline(yintercept = 0, lty = 2, col = "black") +
            coord_cartesian(ylim = c(input$inYlimLB, input$inYlimUB))

        ggplotly(rst)
    })

    ## tb given time
    output$pltCurvesHisto <- renderPlotly({
        rst   <- plot_curves_histo()
        if (is.null(rst))
            return(NULL)
        ggplotly(rst)
    })

    output$pltLastSlope <- renderPlotly({
        rst   <- plot_last_slope()
        if (is.null(rst))
            return(NULL)

        ggplotly(rst)
    })

    ##--------------------------------------
    ##---------POWER ANALYSIS----------------
    ##--------------------------------------
    output$pltSummary <- renderPlotly({
        rst <- plot_pwr_bystudy()
        if (is.null(rst))
            return(NULL)

        ggplotly(rst)
    })

    ## power by random subsets
    output$pltPwrRndSub <- renderPlotly({
        rst <- plot_pwr_sub()
        if (is.null(rst))
            return(NULL)

        ggplotly(rst)

    })

    ## power for x pts by y days
    output$pltPwrXY <- renderPlotly({
        rst <- plot_pwr_xy()
        if (is.null(rst))
            return(NULL)

        ggplotly(rst)
    })



    ##--------------------------------------
    ##---------TEXT-------------------------
    ##--------------------------------------
    output$txtHist <- renderPrint({
        print(get_cur_hist())
    })

    output$txtMsm <- renderPrint({
        dta <- get_data()

        if (is.null(dta))
            return(NULL)

        print(dta$fit_msm)
    })

    output$txtSetting <- renderPrint({
        dta <- get_data()

        if (is.null(dta))
            return(NULL)

        params <- dta$params
        params$dat_tb <- params$dat_surv <- params$inx_b <- NULL
        print(params)
    })

    ##--------------------------------------
    ##---------SURVIVAL---------------------
    ##--------------------------------------
    output$dt_impsurv_summary <- DT::renderDataTable({
        get_impsurv_summary()
    }, options = list(dom = 't'))

    ##--------------------------------------
    ##---------Results----------------------
    ##--------------------------------------
    output$dt_rst <- DT::renderDataTable({
        dat <- get_data()
        if (is.null(dat))
            return(NULL)

        dat$results
    }, options = list(dom = 't'))

    output$tblRst <- DT::renderDataTable({
        endp_label =
            c("adj_utility" = "AUC (Time Adjusted)",
              "utility"     = "AUC",
              "uti_tb"      = "AUC Tumor Burden",
              "uti_event"   = "AUC Survival",
              "uti_ana"     = "Utility at Analysis")

        fname <- get_file_name()

        if (is.null(fname))
            return(NULL)

        if (!file.exists(fname["rst"]))
            return(NULL)

        load(fname["rst"])
        dat <- rst_all$summary %>%
            filter(Outcome == "adj_utility") %>%
            mutate(Outcome = factor(Outcome,
                                     levels = names(endp_label),
                                     labels = endp_label
                                    ),
                   pvalue = format(pvalue, scientific = TRUE)) %>%
            select(-Scenario) %>%
            filter(Outcome != "")

    }, options = list(dom = 't'))

    output$tblAllRst <- DT::renderDataTable({
        get_study_rst() %>%
           mutate(pvalue = format(pvalue, scientific = TRUE))
    }, options = list(pageLength = 50))

    ## ---------------------------------------
    ##  CONDITIONAL PANEL
    ## ---------------------------------------
    output$loadcomplete <- reactive({
        !is.null(get_data())
    })

    outputOptions(output,
                  "loadcomplete",
                  suspendWhenHidden = FALSE)

})