Media geométrica: ¿hay una función incorporada?

106

Intenté encontrar una media geométrica incorporada pero no pude.

(Obviamente, un integrado no me va a ahorrar tiempo mientras trabajo en el shell, ni sospecho que haya ninguna diferencia en la precisión; para los scripts, trato de usar los elementos integrados con la mayor frecuencia posible, donde el (acumulativo) El aumento de rendimiento suele ser notable.

En caso de que no haya uno (que dudo que sea el caso) aquí está el mío.

gm_mean = function(a){prod(a)^(1/length(a))}
doug
fuente
11
Cuidado con los números negativos y los desbordamientos. prod (a) subirá o se desbordará muy rápidamente. Intenté cronometrar esto usando una lista grande y rápidamente obtuve Inf usando su método vs 1.4 con exp (mean (log (x))); el problema del redondeo puede ser bastante severo.
Tristan
Acabo de escribir la función anterior rápidamente porque estaba seguro de que 5 minutos después de publicar esta Q, alguien me diría que R está integrado para gm. Por lo tanto, no está integrado, por lo que vale la pena tomarse el tiempo para volver a codificar a la luz de sus comentarios. +1 de mi parte.
doug
1
Acabo de etiquetar esta media geométrica e incorporada , 9 años después.
smci

Respuestas:

77

Aquí hay una función vectorizada, tolerante a cero y NA para calcular la media geométrica en R. El meancálculo detallado que involucra length(x)es necesario para los casos donde xcontiene valores no positivos.

gm_mean = function(x, na.rm=TRUE){
  exp(sum(log(x[x > 0]), na.rm=na.rm) / length(x))
}

Gracias a @ ben-bolker por señalar la na.rmtransferencia y a @Gregor por asegurarse de que funciona correctamente.

Creo que algunos de los comentarios están relacionados con una falsa equivalencia de NAvalores en los datos y ceros. En la aplicación que tenía en mente, son iguales, pero por supuesto, esto no es cierto en general. Por lo tanto, si desea incluir la propagación opcional de ceros y tratar la length(x)diferencia de manera diferente en el caso de la NAeliminación, la siguiente es una alternativa un poco más larga a la función anterior.

gm_mean = function(x, na.rm=TRUE, zero.propagate = FALSE){
  if(any(x < 0, na.rm = TRUE)){
    return(NaN)
  }
  if(zero.propagate){
    if(any(x == 0, na.rm = TRUE)){
      return(0)
    }
    exp(mean(log(x), na.rm = na.rm))
  } else {
    exp(sum(log(x[x > 0]), na.rm=na.rm) / length(x))
  }
}

Tenga en cuenta que también comprueba los valores negativos y devuelve un valor más informativo y apropiado NaNrespetando que la media geométrica no está definida para valores negativos (pero sí para ceros). Gracias a los comentaristas que se quedaron en mi caso sobre esto.

Paul McMurdie
fuente
2
¿No sería mejor pasar na.rmcomo un argumento (es decir, dejar que el usuario decida si quiere ser tolerante a NA o no, por coherencia con otras funciones de resumen de R)? Estoy nervioso por la exclusión automática de ceros; también lo haría una opción.
Ben Bolker
1
Quizás tengas razón sobre pasar na.rmcomo una opción. Actualizaré mi respuesta. En cuanto a la exclusión de ceros, la media geométrica no está definida para valores no positivos, incluidos los ceros. Lo anterior es una solución común para la media geométrica, en la que a los ceros (o en este caso a todos los que no son cero) se les da un valor ficticio de 1, que no tiene ningún efecto sobre el producto (o, de manera equivalente, cero en la suma logarítmica).
Paul McMurdie
* Me refiero a una solución común para valores no positivos, siendo cero el más común cuando se usa la media geométrica.
Paul McMurdie
1
Su na.rmtransferencia no funciona según lo codificado ... vea gm_mean(c(1:3, NA), na.rm = T). Debe eliminar el & !is.na(x)del subconjunto de vectores y, dado que el primer argumento de sumes ..., debe pasar na.rm = na.rmpor el nombre y también debe excluir 0los y NAdel vector en la lengthllamada.
Gregor Thomas
2
Cuidado: para xcontener solo cero (s), como x <- 0, exp(sum(log(x[x>0]), na.rm = TRUE)/length(x))da 1para la media geométrica, que no tiene sentido.
adatum
88

No, pero hay algunas personas que han escrito uno, como aquí .

Otra posibilidad es usar esto:

exp(mean(log(x)))
Mark Byers
fuente
Otra ventaja de usar exp (mean (log (x))) es que puede trabajar con listas largas de números grandes, lo cual es problemático cuando se usa la fórmula más obvia usando prod (). Tenga en cuenta que prod (a) ^ (1 / length (a)) y exp (mean (log (a))) dan la misma respuesta.
lukeholman
el enlace ha sido arreglado
PatrickT
15

Podemos usar el paquete psych y llamar a la función geometric.mean .

AliCivil
fuente
1
psych::geometric.mean()
smci
Estas funciones deberían tomar la serie y no su crecimiento, al menos como una opción, diría yo.
Christoph Hanck
12

los

exp(mean(log(x)))

funcionará a menos que haya un 0 en x. Si es así, el registro producirá -Inf (-Infinite) que siempre resulta en una media geométrica de 0.

Una solución es eliminar el valor -Inf antes de calcular la media:

geo_mean <- function(data) {
    log_data <- log(data)
    gm <- exp(mean(log_data[is.finite(log_data)]))
    return(gm)
}

Puede usar una sola línea para hacer esto, pero significa calcular el registro dos veces, lo cual es ineficiente.

exp(mean(log(i[is.finite(log(i))])))
Alan James Salmoni
fuente
por qué calcular el registro dos veces cuando puede hacerlo: exp (mean (x [x! = 0]))
zzk
ambos enfoques obtienen la media de forma incorrecta, porque el denominador de la media sum(x) / length(x)es incorrecto si filtra x y luego se lo pasa a mean.
Paul McMurdie
Creo que filtrar es una mala idea a menos que tenga la intención explícita de hacerlo (por ejemplo, si estuviera escribiendo una función de propósito general , no haría que el filtrado sea el predeterminado). Está bien, si se trata de un código único y Pensé con mucho cuidado en lo que realmente significa filtrar los ceros en el contexto de su problema (!)
Ben Bolker
Por definición, una media geométrica de un conjunto de números que contienen cero debe ser cero. math.stackexchange.com/a/91445/221143
Chris
6

Utilizo exactamente lo que dice Mark. De esta manera, incluso con tapply, puede usar la meanfunción incorporada, ¡sin necesidad de definir la suya! Por ejemplo, para calcular medias geométricas por grupo de datos $ valor:

exp(tapply(log(data$value), data$group, mean))
TMS
fuente
3

Esta versión ofrece más opciones que las otras respuestas.

  • Permite al usuario distinguir entre resultados que no son números (reales) y aquellos que no están disponibles. Si hay números negativos, entonces la respuesta no será un número real, por lo que NaNse devuelve. Si son todos los NAvalores, la función volverá en su NA_real_lugar para reflejar que un valor real literalmente no está disponible. Esta es una diferencia sutil, pero una que podría producir resultados (ligeramente) más sólidos.

  • El primer parámetro opcional zero.rmestá destinado a permitir que el usuario tenga ceros que afecten la salida sin convertirla en cero. Si zero.rmse establece en FALSEy etase establece en NA_real_(su valor predeterminado), los ceros tienen el efecto de reducir el resultado a uno. No tengo ninguna justificación teórica para esto, simplemente parece tener más sentido no ignorar los ceros sino "hacer algo" que no implique hacer automáticamente el resultado cero.

  • etaes una forma de manejar ceros que se inspiró en la siguiente discusión: https://support.bioconductor.org/p/64014/

geomean <- function(x,
                    zero.rm = TRUE,
                    na.rm = TRUE,
                    nan.rm = TRUE,
                    eta = NA_real_) {
    nan.count <- sum(is.nan(x))
     na.count <- sum(is.na(x))
  value.count <- if(zero.rm) sum(x[!is.na(x)] > 0) else sum(!is.na(x))

  #Handle cases when there are negative values, all values are missing, or
  #missing values are not tolerated.
  if ((nan.count > 0 & !nan.rm) | any(x < 0, na.rm = TRUE)) {
    return(NaN)
  }
  if ((na.count > 0 & !na.rm) | value.count == 0) {
    return(NA_real_)
  }

  #Handle cases when non-missing values are either all positive or all zero.
  #In these cases the eta parameter is irrelevant and therefore ignored.
  if (all(x > 0, na.rm = TRUE)) {
    return(exp(mean(log(x), na.rm = TRUE)))
  }
  if (all(x == 0, na.rm = TRUE)) {
    return(0)
  }

  #All remaining cases are cases when there are a mix of positive and zero
  #values.
  #By default, we do not use an artificial constant or propagate zeros.
  if (is.na(eta)) {
    return(exp(sum(log(x[x > 0]), na.rm = TRUE) / value.count))
  }
  if (eta > 0) {
    return(exp(mean(log(x + eta), na.rm = TRUE)) - eta)
  }
  return(0) #only propagate zeroes when eta is set to 0 (or less than 0)
}
Chris Coffee
fuente
1
¿Puede agregar algunos detalles que expliquen en qué se diferencia o mejora esto de las soluciones existentes? (Personalmente, no quisiera agregar una dependencia pesada como dplyrpara dicha utilidad a menos que sea necesario ...)
Ben Bolker
Estoy de acuerdo, los case_whens eran un poco tontos, así que los eliminé y la dependencia a favor de ifs. También proporcioné algunos detalles.
Chris Coffee
1
Fui con su última idea y ha cambiado el valor predeterminado de nan.rma TRUEalinear las tres `` `parámetros .rm``.
Chris Coffee
1
Otro detalle estilístico. ifelseestá diseñado para vectorización. Con una sola condición para verificar, sería más idiomático de usarvalue.count <- if(zero.rm) sum(x[!is.na(x)] > 0) else sum(!is.na(x))
Gregor Thomas
También se ve mejor ifelse. Cambiado. ¡Gracias!
Chris Coffee
3

En caso de que falten valores en sus datos, este no es un caso raro. necesitas agregar un argumento más.

Puede probar el siguiente código:

exp(mean(log(i[ is.finite(log(i)) ]), na.rm = TRUE))
Tian Yi
fuente
1
exp(mean(log(x1))) == prod(x1)^(1/length(x1))
usuario12882764
fuente