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=