rdataframeshinyshinydashboardrhandsontable

How to calculate a geometric mean based on cell values?


There are the table 1 and table 2 as shown in the script below. I have the following task: (1) The 1st row of the table 2 should represent a geometric mean of the 1st and 3rd rows of the table 1; (2) The 2nd row of the table 2 = a geometric mean of the 2nd and 4th rows of the table 1.

I would be grateful if someone can help me.

    library(shiny)
    library(shinydashboard)
    library(rhandsontable)
    library(data.table)
    library(dplyr)

    "df1" <- data.table(column1 = as.numeric(c(3,8,3,8)))
    "df2" <- data.table(column2 = as.numeric(c(0,0)))

   ui <- dashboardPage(
    dashboardHeader(title = "Geometric Mean Calculation"),
    dashboardSidebar(
        menuItem("Calculation", tabName = "calculation",
                               menuSubItem("Gmean", tabName = "table1"))),
      dashboardBody(
        tabItems(
          tabItem(
        tabName = "table1",
            column(
              "table 1",
          width=6,
              rHandsontableOutput("Table1")
            ),
            column(
              "table 2",
          width=6,
              rHandsontableOutput("Table2")
            )
          )
        )
      )
    )

   server = function(input, output) {

    data <- reactiveValues()

    observe({input$recalc
            data$`DF1`<- as.data.frame(`df1`)
            data$`DF2`<- as.data.frame(`df2`)
    })
    observe({if(!is.null(input$Table1))
        data$`DF1` <- hot_to_r(input$Table1)
    })
    observe({if(!is.null(input$Table2))
        data$`DF2` <- hot_to_r(input$Table2)
    })

    geometric_mean1<- reactive({with(data$`DF1`, 
                              (column1[1]*column1[3])**(1/2))})
    
    observe({
        if(!is.null(geometric_mean1())){
        data$`DF2`$column2[1] <- geometric_mean1()[[1]]}
    })

    geometric_mean2<- reactive({with(data$`DF1`, 
                               (column1[2]*column1[4])**(1/2))})
    
    observe({
        if(!is.null(geometric_mean2())){
        data$`DF2`$column2[2] <- geometric_mean2()[[1]]}
    })

    output$Table1 <- renderRHandsontable({
        rhandsontable(data$`DF1`)
    })
    output$Table2 <- renderRHandsontable({
        rhandsontable(data$`DF2`)
    })

    }
   
   shinyApp(ui, server)

Solution

  • You asked about "geometry mean", the general function is

    gmean <- function(x, na.rm = FALSE) {
      n <- if (na.rm) sum(!is.na(x)) else length(x)
      prod(x, na.rm = na.rm)^(1/n)
    }
    

    I tweaked the shiny a bit. Some pointers:

    library(shiny)
    library(shinydashboard)
    library(rhandsontable)
    library(data.table)
    library(dplyr)
    
    gmean <- function(x, na.rm = FALSE) {
      n <- if (na.rm) sum(!is.na(x)) else length(x)
      prod(x, na.rm = na.rm)^(1/n)
    }
    
    df1 <- data.table(column1 = c(3,8,3,8))
    df2 <- data.table(column2 = c(0,0))
    
    ui <- dashboardPage(
      dashboardHeader(title = "Geometric Mean Calculation"),
      dashboardSidebar(
        menuItem("Calculation", tabName = "calculation",
                 menuSubItem("Gmean", tabName = "table1"))),
      dashboardBody(
        actionButton("button", label = "Debug!"),
        tabItems(
          tabItem(
            tabName = "table1",
            column(
              "table 1",
              width=6,
              rHandsontableOutput("Table1")
            ),
            column(
              "table 2",
              width=6,
              rHandsontableOutput("Table2")
            )
          )
        )
      )
    )
    
    
    server = function(input, output) {
      data <- reactiveValues()
    
      observe({
        req(input$Table1)
        data$DF1 <- hot_to_r(input$Table1)
      })
      observe({
        req(input$Table2)
        data$DF2 <- hot_to_r(input$Table2)
      })
    
      observe({
        # input$recalc # ??? no idea
        data$DF1 <- df1
        # data$DF2 <- df2
      })
    
      output$Table1 <- renderRHandsontable({
        req(data$DF1)
        rhandsontable(data$DF1)
      })
      output$Table2 <- renderRHandsontable({
        req(input$Table1, data$DF1)
        data.frame(column2 = c(
          gmean(data$DF1$column1[c(1,3)]),
          gmean(data$DF1$column1[c(2,4)])
        )) |>
          rhandsontable()
      })
      observeEvent(input$button, { browser();1;})
    
    }
    
    shinyApp(ui, server)