Resuelva las situaicones que se le presentan a continuación. Para cada una de las situaciones deberán generar un gráfico en ggplot que acompañe a la resolución.

Problema 1

En un laboratorio de botánica se sembraron plántulas de frijol (Phaseolus vulgaris) bajo condiciones controladas: luz constante, temperatura de 25 °C y riego regular. Cada 2 días se midió la altura de 10 plántulas y se registró el promedio. Su grupo debe estimar la tasa de crecimiento de las plántulas con un modelo lineal. Si ustedes tuvieran a cargo de laboratorio, qué decisiones tomarían para que el crecimiento sea mayor.

Ahora, con ese modelo, haga una predicción de cuál será el tamañao de las plantas en los días 40 y 52.


# nuevos_datos <- data.frame(Tiempo= c(40,52))

# predict(modelo, nuevos_datos)

Respuesta


library(readxl)
library(ggplot2)
library(growthrates)
datos_p1 <- read_excel("Problemas_Modelos.xlsx", sheet = "Problema1")
datos_p2 <- read_excel("Problemas_Modelos.xlsx", sheet = "Problema2")
datos_p3 <- read_excel("Problemas_Modelos.xlsx", sheet = "Problema3")
modelo1 <- lm(Altura ~ Tiempo, data = datos_p1)
summary(modelo1)
nuevos_datos <- data.frame(Tiempo = c(40, 52))
predicciones <- predict(modelo1, nuevos_datos)
data.frame(
  Dia = c(40, 52),
  Altura_Predicha_cm = predicciones
)
ggplot(datos_p1, aes(x = Tiempo, y = Altura)) +
  geom_point(color = "lightgreen", size = 3) +
  geom_smooth(method = "lm", color = "darkgreen", se = TRUE) +
  labs(,
    x = "Tiempo (Días)",
    y = "Altura Promedio (cm)"
  ) +
  theme_minimal()

Problema 2

La lapa roja o guacamaya roja (Ara macao) fue casi eliminada de buena parte del Pacífico de Costa Rica por la pérdida de bosque y la captura de polluelos. Gracias a programas de conservación y reintroducción, algunas poblaciones se han recuperado.

Imaginen que un programa de conservación liberó un grupo pequeño de lapas rojas en un bosque protegido del Pacífico central y las censó cada año durante 20 años. Ustedes deben ajustar un modelo logístico a los datos y estimar los parámetros que describen el crecimiento de esta población. Como tomadores de decisión, especifiquen cuándo deberá de terminar el monitoreo ecológico, según el comportamiento poblacional.

Respuesta

library(growthrates)
library(ggplot2)

tiempo_vec <- seq(1, 20, length.out = 100)
parametros <- c(y0 = 12, mumax = 0.1, K = 200)

sim_mat <- grow_logistic(tiempo_vec, parms = parametros)

datos_sim2 <- data.frame(
  tiempo = sim_mat[, "time"],
  y = sim_mat[, "y"]
)

ggplot(datos_sim2, aes(x = tiempo, y = y)) +
 
  geom_hline(yintercept = parametros["K"], linetype = "dashed", 
             color = "#2A9D8F", linewidth = 0.8) +
  annotate("text", x = 1, y = parametros["K"], 
           label = paste0("Capacidad de carga (K) = ", parametros["K"]), 
           hjust = 0, vjust = -0.6, color = "#2A9D8F", fontface = "bold") +

  geom_line(color = "#264653", linewidth = 1.2) +

  geom_point(color = "#E76F51", fill = "#F4A261", shape = 21, 
             size = 2.5, stroke = 0.8) +
  labs(
    x = "Tiempo ",
    y = "Individuos"
  ) +
  theme_minimal(base_size = 12) +
  theme(
    plot.title    = element_text(face = "bold", color = "#264653"),
    plot.subtitle = element_text(color = "grey40"),
    panel.grid.minor = element_blank()
  )

Problema 3

En los bosques nubosos de la cordillera de Tilarán, un anfibio endémico (especie ficticia, inspirada en lo ocurrido con el sapo dorado de Monteverde) mantenía una población estable de unos 500 individuos. A partir de cierto momento, la llegada de un hongo patógeno (quitridiomicosis) y el aumento de la temperatura hicieron que las muertes superaran a los nacimientos. Un equipo de biólogos censó la población cada año durante 12 años. (mumax = -0.3, K = 550)

Ustedes deben ajustar un modelo logístico con tasa de crecimiento y usarlo para predecir cuándo desaparecerá la población.

Respuesta

library(growthrates)
ajuste <- fit_growthmodel(
  FUN   = grow_logistic,
  p     = c(y0 = 480, mumax = -0.3, K = 550),   
  time  = datos_p3$Muestreo,
  y     = datos_p3$Individuos,
  lower = c(y0 = 1,    mumax = -3, K = 1),
  upper = c(y0 = 2000, mumax = 0,  K = 5000)
)
summary(ajuste)
p <- coef(ajuste)
t_alcanza <- function(N, p) {
  with(as.list(p), log(N * (K - y0) / (y0 * (K - N))) / mumax)
}

tiempo_extincion <- t_alcanza(0.1, p)
cat("La población colapsará casi por completo en aprox.", round(tiempo_extincion, 2), "años.\n")
ggplot(datos_p3, aes(x = Muestreo, y = Individuos)) +
  geom_point(color = "purple", size = 3) +
  geom_line(aes(y = predict(ajuste)[, "y"]), color = "violet", linewidth = 1) +
  geom_vline(xintercept = tiempo_extincion, linetype = "dashed", color = "black") +
  labs(,
    x = "Tiempo ",
    y = "Individuos"
  ) +
  theme_minimal()
  
LS0tDQp0aXRsZTogIlIgTm90ZWJvb2siDQpvdXRwdXQ6IA0KICBodG1sX25vdGVib29rOiANCiAgICB0b2M6IHRydWUNCiAgICB0aGVtZTogdW5pdGVkDQotLS0NCg0KUmVzdWVsdmEgbGFzIHNpdHVhaWNvbmVzIHF1ZSBzZSBsZSBwcmVzZW50YW4gYSBjb250aW51YWNpw7NuLiBQYXJhIGNhZGEgdW5hIGRlIGxhcyBzaXR1YWNpb25lcyBkZWJlcsOhbiBnZW5lcmFyIHVuIGdyw6FmaWNvIGVuIGdncGxvdCBxdWUgYWNvbXBhw7FlIGEgbGEgcmVzb2x1Y2nDs24uDQoNCiMgUHJvYmxlbWEgMQ0KDQpFbiB1biBsYWJvcmF0b3JpbyBkZSBib3TDoW5pY2Egc2Ugc2VtYnJhcm9uIHBsw6FudHVsYXMgZGUgZnJpam9sICgqUGhhc2VvbHVzIHZ1bGdhcmlzKikgYmFqbyBjb25kaWNpb25lcyBjb250cm9sYWRhczogbHV6IGNvbnN0YW50ZSwgdGVtcGVyYXR1cmEgZGUgMjUgwrBDIHkgcmllZ28gcmVndWxhci4gQ2FkYSAyIGTDrWFzIHNlIG1pZGnDsyBsYSBhbHR1cmEgZGUgMTAgcGzDoW50dWxhcyB5IHNlIHJlZ2lzdHLDsyBlbCBwcm9tZWRpby4gU3UgZ3J1cG8gZGViZSBlc3RpbWFyIGxhwqAqKnRhc2EgZGUgY3JlY2ltaWVudG8qKsKgZGUgbGFzIHBsw6FudHVsYXMgY29uIHVuIG1vZGVsbyBsaW5lYWwuIFNpIHVzdGVkZXMgdHV2aWVyYW4gYSBjYXJnbyBkZSBsYWJvcmF0b3JpbywgcXXDqSBkZWNpc2lvbmVzIHRvbWFyw61hbiBwYXJhIHF1ZSBlbCBjcmVjaW1pZW50byBzZWEgbWF5b3IuDQoNCkFob3JhLCBjb24gZXNlIG1vZGVsbywgaGFnYSB1bmEgcHJlZGljY2nDs24gZGUgY3XDoWwgc2Vyw6EgZWwgdGFtYcOxYW8gZGUgbGFzIHBsYW50YXMgZW4gbG9zIGTDrWFzIDQwIHkgNTIuDQoNCmBgYHtyfQ0KDQojIG51ZXZvc19kYXRvcyA8LSBkYXRhLmZyYW1lKFRpZW1wbz0gYyg0MCw1MikpDQoNCiMgcHJlZGljdChtb2RlbG8sIG51ZXZvc19kYXRvcykNCmBgYA0KDQojIyBSZXNwdWVzdGENCmBgYHtyfQ0KDQpsaWJyYXJ5KHJlYWR4bCkNCmxpYnJhcnkoZ2dwbG90MikNCmxpYnJhcnkoZ3Jvd3RocmF0ZXMpDQoNCmBgYA0KDQoNCmBgYHtyfQ0KZGF0b3NfcDEgPC0gcmVhZF9leGNlbCgiUHJvYmxlbWFzX01vZGVsb3MueGxzeCIsIHNoZWV0ID0gIlByb2JsZW1hMSIpDQpkYXRvc19wMiA8LSByZWFkX2V4Y2VsKCJQcm9ibGVtYXNfTW9kZWxvcy54bHN4Iiwgc2hlZXQgPSAiUHJvYmxlbWEyIikNCmRhdG9zX3AzIDwtIHJlYWRfZXhjZWwoIlByb2JsZW1hc19Nb2RlbG9zLnhsc3giLCBzaGVldCA9ICJQcm9ibGVtYTMiKQ0KYGBgDQoNCmBgYHtyfQ0KbW9kZWxvMSA8LSBsbShBbHR1cmEgfiBUaWVtcG8sIGRhdGEgPSBkYXRvc19wMSkNCnN1bW1hcnkobW9kZWxvMSkNCg0KYGBgDQoNCg0KYGBge3J9DQpudWV2b3NfZGF0b3MgPC0gZGF0YS5mcmFtZShUaWVtcG8gPSBjKDQwLCA1MikpDQpwcmVkaWNjaW9uZXMgPC0gcHJlZGljdChtb2RlbG8xLCBudWV2b3NfZGF0b3MpDQpgYGANCg0KYGBge3J9DQpkYXRhLmZyYW1lKA0KICBEaWEgPSBjKDQwLCA1MiksDQogIEFsdHVyYV9QcmVkaWNoYV9jbSA9IHByZWRpY2Npb25lcw0KKQ0KDQpgYGANCg0KDQpgYGB7cn0NCmdncGxvdChkYXRvc19wMSwgYWVzKHggPSBUaWVtcG8sIHkgPSBBbHR1cmEpKSArDQogIGdlb21fcG9pbnQoY29sb3IgPSAibGlnaHRncmVlbiIsIHNpemUgPSAzKSArDQogIGdlb21fc21vb3RoKG1ldGhvZCA9ICJsbSIsIGNvbG9yID0gImRhcmtncmVlbiIsIHNlID0gVFJVRSkgKw0KICBsYWJzKCwNCiAgICB4ID0gIlRpZW1wbyAoRMOtYXMpIiwNCiAgICB5ID0gIkFsdHVyYSBQcm9tZWRpbyAoY20pIg0KICApICsNCiAgdGhlbWVfbWluaW1hbCgpDQpgYGANCg0KIyBQcm9ibGVtYSAyDQoNCkxhIGxhcGEgcm9qYSBvIGd1YWNhbWF5YSByb2phICgqQXJhIG1hY2FvKikgZnVlIGNhc2kgZWxpbWluYWRhIGRlIGJ1ZW5hIHBhcnRlIGRlbCBQYWPDrWZpY28gZGUgQ29zdGEgUmljYSBwb3IgbGEgcMOpcmRpZGEgZGUgYm9zcXVlIHkgbGEgY2FwdHVyYSBkZSBwb2xsdWVsb3MuIEdyYWNpYXMgYSBwcm9ncmFtYXMgZGUgY29uc2VydmFjacOzbiB5IHJlaW50cm9kdWNjacOzbiwgYWxndW5hcyBwb2JsYWNpb25lcyBzZSBoYW4gcmVjdXBlcmFkby4NCg0KSW1hZ2luZW4gcXVlIHVuIHByb2dyYW1hIGRlIGNvbnNlcnZhY2nDs24gbGliZXLDsyB1biBncnVwbyBwZXF1ZcOxbyBkZSBsYXBhcyByb2phcyBlbiB1biBib3NxdWUgcHJvdGVnaWRvIGRlbCBQYWPDrWZpY28gY2VudHJhbCB5IGxhcyBjZW5zw7PCoCoqY2FkYSBhw7FvIGR1cmFudGUgMjAgYcOxb3MqKi4gVXN0ZWRlcyBkZWJlbiBhanVzdGFyIHVuwqAqKm1vZGVsbyBsb2fDrXN0aWNvKirCoGEgbG9zIGRhdG9zIHkgZXN0aW1hciBsb3MgcGFyw6FtZXRyb3MgcXVlIGRlc2NyaWJlbiBlbCBjcmVjaW1pZW50byBkZSBlc3RhIHBvYmxhY2nDs24uIENvbW8gdG9tYWRvcmVzIGRlIGRlY2lzacOzbiwgZXNwZWNpZmlxdWVuIGN1w6FuZG8gZGViZXLDoSBkZSB0ZXJtaW5hciBlbCBtb25pdG9yZW8gZWNvbMOzZ2ljbywgc2Vnw7puIGVsIGNvbXBvcnRhbWllbnRvIHBvYmxhY2lvbmFsLg0KDQojIyBSZXNwdWVzdGENCg0KYGBge3J9DQpsaWJyYXJ5KGdyb3d0aHJhdGVzKQ0KbGlicmFyeShnZ3Bsb3QyKQ0KDQp0aWVtcG9fdmVjIDwtIHNlcSgxLCAyMCwgbGVuZ3RoLm91dCA9IDEwMCkNCnBhcmFtZXRyb3MgPC0gYyh5MCA9IDEyLCBtdW1heCA9IDAuMSwgSyA9IDIwMCkNCg0Kc2ltX21hdCA8LSBncm93X2xvZ2lzdGljKHRpZW1wb192ZWMsIHBhcm1zID0gcGFyYW1ldHJvcykNCg0KZGF0b3Nfc2ltMiA8LSBkYXRhLmZyYW1lKA0KICB0aWVtcG8gPSBzaW1fbWF0WywgInRpbWUiXSwNCiAgeSA9IHNpbV9tYXRbLCAieSJdDQopDQoNCmdncGxvdChkYXRvc19zaW0yLCBhZXMoeCA9IHRpZW1wbywgeSA9IHkpKSArDQogDQogIGdlb21faGxpbmUoeWludGVyY2VwdCA9IHBhcmFtZXRyb3NbIksiXSwgbGluZXR5cGUgPSAiZGFzaGVkIiwgDQogICAgICAgICAgICAgY29sb3IgPSAiIzJBOUQ4RiIsIGxpbmV3aWR0aCA9IDAuOCkgKw0KICBhbm5vdGF0ZSgidGV4dCIsIHggPSAxLCB5ID0gcGFyYW1ldHJvc1siSyJdLCANCiAgICAgICAgICAgbGFiZWwgPSBwYXN0ZTAoIkNhcGFjaWRhZCBkZSBjYXJnYSAoSykgPSAiLCBwYXJhbWV0cm9zWyJLIl0pLCANCiAgICAgICAgICAgaGp1c3QgPSAwLCB2anVzdCA9IC0wLjYsIGNvbG9yID0gIiMyQTlEOEYiLCBmb250ZmFjZSA9ICJib2xkIikgKw0KDQogIGdlb21fbGluZShjb2xvciA9ICIjMjY0NjUzIiwgbGluZXdpZHRoID0gMS4yKSArDQoNCiAgZ2VvbV9wb2ludChjb2xvciA9ICIjRTc2RjUxIiwgZmlsbCA9ICIjRjRBMjYxIiwgc2hhcGUgPSAyMSwgDQogICAgICAgICAgICAgc2l6ZSA9IDIuNSwgc3Ryb2tlID0gMC44KSArDQogIGxhYnMoDQogICAgeCA9ICJUaWVtcG8gIiwNCiAgICB5ID0gIkluZGl2aWR1b3MiDQogICkgKw0KICB0aGVtZV9taW5pbWFsKGJhc2Vfc2l6ZSA9IDEyKSArDQogIHRoZW1lKA0KICAgIHBsb3QudGl0bGUgICAgPSBlbGVtZW50X3RleHQoZmFjZSA9ICJib2xkIiwgY29sb3IgPSAiIzI2NDY1MyIpLA0KICAgIHBsb3Quc3VidGl0bGUgPSBlbGVtZW50X3RleHQoY29sb3IgPSAiZ3JleTQwIiksDQogICAgcGFuZWwuZ3JpZC5taW5vciA9IGVsZW1lbnRfYmxhbmsoKQ0KICApDQpgYGANCg0KDQojIFByb2JsZW1hIDMNCg0KRW4gbG9zIGJvc3F1ZXMgbnVib3NvcyBkZSBsYSBjb3JkaWxsZXJhIGRlIFRpbGFyw6FuLCB1biBhbmZpYmlvIGVuZMOpbWljbyAoZXNwZWNpZSBmaWN0aWNpYSwgaW5zcGlyYWRhIGVuIGxvIG9jdXJyaWRvIGNvbiBlbCBzYXBvIGRvcmFkbyBkZSBNb250ZXZlcmRlKSBtYW50ZW7DrWEgdW5hIHBvYmxhY2nDs24gZXN0YWJsZSBkZSB1bm9zIDUwMCBpbmRpdmlkdW9zLiBBIHBhcnRpciBkZSBjaWVydG8gbW9tZW50bywgbGEgbGxlZ2FkYSBkZSB1biBob25nbyBwYXTDs2dlbm8gKHF1aXRyaWRpb21pY29zaXMpIHkgZWwgYXVtZW50byBkZSBsYSB0ZW1wZXJhdHVyYSBoaWNpZXJvbiBxdWUgbGFzIG11ZXJ0ZXMgc3VwZXJhcmFuIGEgbG9zIG5hY2ltaWVudG9zLiBVbiBlcXVpcG8gZGUgYmnDs2xvZ29zIGNlbnPDsyBsYSBwb2JsYWNpw7NuwqAqKmNhZGEgYcOxbyBkdXJhbnRlIDEyIGHDsW9zKiouIChtdW1heCA9IC0wLjMsIEsgPSA1NTApDQoNClVzdGVkZXMgZGViZW4gYWp1c3RhciB1bsKgKiptb2RlbG8gbG9nw61zdGljbyBjb24gdGFzYSBkZSBjcmVjaW1pZW50byoqwqB5IHVzYXJsbyBwYXJhIHByZWRlY2lywqAqKmN1w6FuZG8gZGVzYXBhcmVjZXLDoSBsYSBwb2JsYWNpw7NuKiouDQoNCg0KIyMgUmVzcHVlc3RhDQpgYGB7cn0NCmxpYnJhcnkoZ3Jvd3RocmF0ZXMpDQpgYGANCmBgYHtyfQ0KYWp1c3RlIDwtIGZpdF9ncm93dGhtb2RlbCgNCiAgRlVOICAgPSBncm93X2xvZ2lzdGljLA0KICBwICAgICA9IGMoeTAgPSA0ODAsIG11bWF4ID0gLTAuMywgSyA9IDU1MCksICAgDQogIHRpbWUgID0gZGF0b3NfcDMkTXVlc3RyZW8sDQogIHkgICAgID0gZGF0b3NfcDMkSW5kaXZpZHVvcywNCiAgbG93ZXIgPSBjKHkwID0gMSwgICAgbXVtYXggPSAtMywgSyA9IDEpLA0KICB1cHBlciA9IGMoeTAgPSAyMDAwLCBtdW1heCA9IDAsICBLID0gNTAwMCkNCikNCg0KYGBgDQoNCg0KYGBge3J9DQpzdW1tYXJ5KGFqdXN0ZSkNCnAgPC0gY29lZihhanVzdGUpDQpgYGANCg0KYGBge3J9DQp0X2FsY2FuemEgPC0gZnVuY3Rpb24oTiwgcCkgew0KICB3aXRoKGFzLmxpc3QocCksIGxvZyhOICogKEsgLSB5MCkgLyAoeTAgKiAoSyAtIE4pKSkgLyBtdW1heCkNCn0NCmBgYA0KYGBge3J9DQoNCnRpZW1wb19leHRpbmNpb24gPC0gdF9hbGNhbnphKDAuMSwgcCkNCmNhdCgiTGEgcG9ibGFjacOzbiBjb2xhcHNhcsOhIGNhc2kgcG9yIGNvbXBsZXRvIGVuIGFwcm94LiIsIHJvdW5kKHRpZW1wb19leHRpbmNpb24sIDIpLCAiYcOxb3MuXG4iKQ0KYGBgDQpgYGB7cn0NCmdncGxvdChkYXRvc19wMywgYWVzKHggPSBNdWVzdHJlbywgeSA9IEluZGl2aWR1b3MpKSArDQogIGdlb21fcG9pbnQoY29sb3IgPSAicHVycGxlIiwgc2l6ZSA9IDMpICsNCiAgZ2VvbV9saW5lKGFlcyh5ID0gcHJlZGljdChhanVzdGUpWywgInkiXSksIGNvbG9yID0gInZpb2xldCIsIGxpbmV3aWR0aCA9IDEpICsNCiAgZ2VvbV92bGluZSh4aW50ZXJjZXB0ID0gdGllbXBvX2V4dGluY2lvbiwgbGluZXR5cGUgPSAiZGFzaGVkIiwgY29sb3IgPSAiYmxhY2siKSArDQogIGxhYnMoLA0KICAgIHggPSAiVGllbXBvICIsDQogICAgeSA9ICJJbmRpdmlkdW9zIg0KICApICsNCiAgdGhlbWVfbWluaW1hbCgpDQogIA0KYGBgDQoNCg0KICA=