R: minpack.lm::nls.lm failed with good results - r
I use nls.lm from the minpack.lm package to fit a lot of non linear models.
It often fails after 20 iterations because of a singular gradient matrix at initial parameter estimates.
The problem is when I have a look at the iterations before failling (trace = T) I can see the results was ok.
Reproductible example:
Data:
df <- structure(list(x1 = c(7L, 5L, 10L, 6L, 9L, 10L, 2L, 4L, 9L, 3L,
11L, 6L, 4L, 0L, 7L, 12L, 9L, 11L, 11L, 0L, 2L, 3L, 5L, 6L, 6L,
9L, 1L, 7L, 7L, 4L, 3L, 13L, 12L, 13L, 5L, 0L, 5L, 6L, 6L, 7L,
5L, 10L, 6L, 10L, 0L, 7L, 9L, 12L, 4L, 5L, 6L, 3L, 4L, 5L, 5L,
0L, 9L, 9L, 1L, 2L, 2L, 13L, 8L, 2L, 5L, 10L, 6L, 11L, 5L, 0L,
4L, 4L, 8L, 9L, 4L, 2L, 12L, 4L, 10L, 7L, 0L, 4L, 4L, 5L, 8L,
8L, 12L, 4L, 6L, 13L, 5L, 12L, 1L, 6L, 4L, 9L, 11L, 11L, 6L,
10L, 10L, 0L, 3L, 1L, 11L, 4L, 3L, 13L, 5L, 4L, 2L, 3L, 11L,
7L, 0L, 9L, 6L, 11L, 6L, 13L, 1L, 5L, 0L, 6L, 4L, 8L, 2L, 3L,
7L, 9L, 12L, 11L, 7L, 4L, 10L, 0L, 6L, 1L, 7L, 2L, 6L, 3L, 1L,
6L, 10L, 12L, 7L, 7L, 6L, 6L, 1L, 7L, 8L, 7L, 7L, 5L, 7L, 10L,
10L, 11L, 7L, 1L, 8L, 3L, 12L, 0L, 11L, 8L, 5L, 0L, 6L, 3L, 2L,
2L, 8L, 9L, 2L, 8L, 2L, 13L, 10L, 2L, 12L, 6L, 13L, 2L, 11L,
1L, 12L, 6L, 7L, 9L, 8L, 10L, 2L, 6L, 0L, 2L, 11L, 2L, 3L, 9L,
12L, 1L, 11L, 11L, 12L, 4L, 6L, 9L, 1L, 4L, 1L, 8L, 8L, 6L, 1L,
9L, 8L, 2L, 10L, 10L, 1L, 2L, 0L, 11L, 6L, 6L, 0L, 4L, 13L, 4L,
8L, 4L, 10L, 9L, 6L, 11L, 8L, 1L, 6L, 5L, 10L, 8L, 10L, 8L, 0L,
3L, 0L, 6L, 7L, 4L, 3L, 7L, 7L, 8L, 6L, 2L, 9L, 5L, 7L, 7L, 0L,
7L, 2L, 5L, 5L, 7L, 5L, 7L, 8L, 6L, 1L, 2L, 6L, 0L, 8L, 10L,
0L, 10L), x2 = c(4L, 6L, 1L, 5L, 4L, 1L, 8L, 9L, 4L, 7L, 2L,
6L, 9L, 11L, 5L, 1L, 3L, 2L, 2L, 12L, 8L, 9L, 6L, 4L, 4L, 2L,
9L, 6L, 6L, 6L, 8L, 0L, 0L, 0L, 8L, 10L, 7L, 7L, 4L, 5L, 5L,
3L, 6L, 3L, 12L, 6L, 1L, 0L, 8L, 6L, 6L, 7L, 8L, 5L, 8L, 11L,
3L, 2L, 12L, 11L, 10L, 0L, 2L, 8L, 8L, 3L, 7L, 2L, 7L, 10L, 7L,
8L, 2L, 4L, 7L, 11L, 1L, 8L, 2L, 5L, 11L, 9L, 7L, 5L, 5L, 3L,
1L, 8L, 4L, 0L, 5L, 0L, 12L, 5L, 9L, 1L, 2L, 0L, 5L, 0L, 2L,
10L, 9L, 10L, 0L, 8L, 10L, 0L, 6L, 8L, 8L, 7L, 1L, 6L, 10L, 1L,
5L, 1L, 6L, 0L, 12L, 7L, 13L, 6L, 9L, 2L, 11L, 10L, 5L, 2L, 0L,
2L, 5L, 6L, 2L, 10L, 4L, 10L, 4L, 9L, 5L, 9L, 11L, 4L, 3L, 1L,
6L, 3L, 7L, 7L, 10L, 3L, 3L, 6L, 3L, 7L, 4L, 1L, 0L, 1L, 4L,
11L, 4L, 10L, 0L, 11L, 0L, 3L, 5L, 11L, 5L, 8L, 10L, 9L, 4L,
3L, 10L, 4L, 10L, 0L, 3L, 9L, 1L, 7L, 0L, 8L, 1L, 11L, 0L, 5L,
4L, 2L, 2L, 0L, 11L, 6L, 13L, 9L, 1L, 9L, 7L, 3L, 1L, 12L, 2L,
2L, 1L, 6L, 4L, 2L, 10L, 6L, 10L, 2L, 3L, 4L, 9L, 2L, 5L, 10L,
0L, 0L, 10L, 9L, 12L, 0L, 7L, 5L, 10L, 6L, 0L, 9L, 4L, 8L, 1L,
3L, 5L, 2L, 4L, 12L, 4L, 5L, 2L, 5L, 0L, 2L, 10L, 8L, 10L, 7L,
3L, 8L, 8L, 6L, 3L, 5L, 6L, 11L, 4L, 5L, 4L, 3L, 10L, 6L, 8L,
6L, 7L, 4L, 8L, 5L, 3L, 7L, 12L, 8L, 4L, 11L, 2L, 3L, 12L, 1L
), x3 = c(1, 1, 1, 1, 3, 1, 0, 3, 3, 0, 3, 2, 3, 1, 2, 3, 2,
3, 3, 2, 0, 2, 1, 0, 0, 1, 0, 3, 3, 0, 1, 3, 2, 3, 3, 0, 2, 3,
0, 2, 0, 3, 2, 3, 2, 3, 0, 2, 2, 1, 2, 0, 2, 0, 3, 1, 2, 1, 3,
3, 2, 3, 0, 0, 3, 3, 3, 3, 2, 0, 1, 2, 0, 3, 1, 3, 3, 2, 2, 2,
1, 3, 1, 0, 3, 1, 3, 2, 0, 3, 0, 2, 3, 1, 3, 0, 3, 1, 1, 0, 2,
0, 2, 1, 1, 2, 3, 3, 1, 2, 0, 0, 2, 3, 0, 0, 1, 2, 2, 3, 3, 2,
3, 2, 3, 0, 3, 3, 2, 1, 2, 3, 2, 0, 2, 0, 0, 1, 1, 1, 1, 2, 2,
0, 3, 3, 3, 0, 3, 3, 1, 0, 1, 3, 0, 2, 1, 1, 0, 2, 1, 2, 2, 3,
2, 1, 1, 1, 0, 1, 1, 1, 2, 1, 2, 2, 2, 2, 2, 3, 3, 1, 3, 3, 3,
0, 2, 2, 2, 1, 1, 1, 0, 0, 3, 2, 3, 1, 2, 1, 0, 2, 3, 3, 3, 3,
3, 0, 0, 1, 1, 0, 1, 0, 1, 0, 0, 1, 3, 2, 0, 0, 1, 1, 2, 1, 3,
1, 0, 0, 3, 3, 2, 2, 1, 2, 1, 3, 2, 3, 0, 0, 2, 3, 0, 0, 0, 1,
0, 3, 0, 2, 1, 3, 0, 3, 2, 3, 3, 0, 1, 0, 0, 3, 0, 1, 2, 1, 3,
2, 1, 3, 3, 0, 0, 1, 0, 3, 2, 1), y = c(0.03688, 0.09105, 0.16246,
0, 0.11024, 0.16246, 0.13467, 0, 0.11024, 0.0807, 0.12726, 0.03934,
0, 0.0826, 0.03688, 0.06931, 0.1378, 0.12726, 0.12726, 0.08815,
0.13467, 0.01314, 0.09105, 0.12077, 0.12077, 0.02821, 0.15134,
0.03604, 0.03604, 0.08729, 0.04035, 0.46088, 0.20987, 0.46088,
0.06672, 0.24121, 0.08948, 0.07867, 0.12077, 0.03688, 0.02276,
0.04535, 0.03934, 0.04535, 0.08815, 0.03604, 0.50771, 0.20987,
0.08569, 0.09105, 0.03934, 0.0807, 0.08569, 0.02276, 0.06672,
0.0826, 0.1378, 0.02821, 0.03943, 0.03589, 0.04813, 0.46088,
0.22346, 0.13467, 0.06672, 0.04535, 0.07867, 0.12726, 0.08948,
0.24121, 0.06983, 0.08569, 0.22346, 0.11024, 0.06983, 0.03589,
0.06931, 0.08569, 0.04589, 0.03688, 0.0826, 0, 0.06983, 0.02276,
0.06238, 0.03192, 0.06931, 0.08569, 0.12077, 0.46088, 0.02276,
0.20987, 0.03943, 0, 0, 0.50771, 0.12726, 0.1628, 0, 0.41776,
0.04589, 0.24121, 0.01314, 0.03027, 0.1628, 0.08569, 0, 0.46088,
0.09105, 0.08569, 0.13467, 0.0807, 0.12912, 0.03604, 0.24121,
0.50771, 0, 0.12912, 0.03934, 0.46088, 0.03943, 0.08948, 0.07103,
0.03934, 0, 0.22346, 0.03589, 0, 0.03688, 0.02821, 0.20987, 0.12726,
0.03688, 0.08729, 0.04589, 0.24121, 0.12077, 0.03027, 0.03688,
0.03673, 0, 0.01314, 0.02957, 0.12077, 0.04535, 0.06931, 0.03604,
0.36883, 0.07867, 0.07867, 0.03027, 0.36883, 0.03192, 0.03604,
0.36883, 0.08948, 0.03688, 0.16246, 0.41776, 0.12912, 0.03688,
0.02957, 0.1255, 0, 0.20987, 0.0826, 0.1628, 0.03192, 0.02276,
0.0826, 0, 0.04035, 0.04813, 0.03673, 0.1255, 0.1378, 0.04813,
0.1255, 0.04813, 0.46088, 0.04535, 0.03673, 0.06931, 0.07867,
0.46088, 0.13467, 0.12912, 0.02957, 0.20987, 0, 0.03688, 0.02821,
0.22346, 0.41776, 0.03589, 0.03934, 0.07103, 0.03673, 0.12912,
0.03673, 0.0807, 0.1378, 0.06931, 0.03943, 0.12726, 0.12726,
0.06931, 0.08729, 0.12077, 0.02821, 0.03027, 0.08729, 0.03027,
0.22346, 0.03192, 0.12077, 0.15134, 0.02821, 0.06238, 0.04813,
0.41776, 0.41776, 0.03027, 0.03673, 0.08815, 0.1628, 0.07867,
0, 0.24121, 0.08729, 0.46088, 0, 0.1255, 0.08569, 0.16246, 0.1378,
0, 0.12726, 0.1255, 0.03943, 0.12077, 0.02276, 0.04589, 0.06238,
0.41776, 0.22346, 0.24121, 0.04035, 0.24121, 0.07867, 0.36883,
0.08569, 0.04035, 0.03604, 0.36883, 0.06238, 0.03934, 0.03589,
0.11024, 0.02276, 0.03688, 0.36883, 0.24121, 0.03604, 0.13467,
0.09105, 0.08948, 0.03688, 0.06672, 0.03688, 0.03192, 0.07867,
0.03943, 0.13467, 0.12077, 0.0826, 0.22346, 0.04535, 0.08815,
0.16246)), .Names = c("x1", "x2", "x3", "y"), row.names = c(995L,
1416L, 281L, 1192L, 1075L, 294L, 1812L, 2235L, 1097L, 1583L,
670L, 1485L, 2199L, 2495L, 1259L, 436L, 803L, 631L, 617L, 2654L,
1813L, 2180L, 1403L, 911L, 927L, 533L, 2024L, 1517L, 1522L, 1356L,
1850L, 222L, 115L, 204L, 1974L, 2292L, 1695L, 1746L, 915L, 1283L,
1128L, 880L, 1467L, 887L, 2665L, 1532L, 267L, 155L, 1933L, 1447L,
1488L, 1609L, 1922L, 1168L, 1965L, 2479L, 813L, 550L, 2707L,
2590L, 2373L, 190L, 504L, 1810L, 2007L, 843L, 1770L, 659L, 1730L,
2246L, 1668L, 1923L, 465L, 1108L, 1663L, 2616L, 409L, 1946L,
589L, 1277L, 2493L, 2210L, 1662L, 1142L, 1331L, 735L, 430L, 1916L,
922L, 208L, 1134L, 127L, 2693L, 1213L, 2236L, 240L, 623L, 108L,
1190L, 9L, 575L, 2268L, 2171L, 2308L, 103L, 1953L, 2409L, 184L,
1437L, 1947L, 1847L, 1570L, 365L, 1550L, 2278L, 270L, 1204L,
384L, 1472L, 205L, 2694L, 1727L, 2800L, 1476L, 2229L, 453L, 2630L,
2426L, 1275L, 523L, 163L, 635L, 1287L, 1349L, 561L, 2261L, 931L,
2339L, 973L, 2113L, 1229L, 2155L, 2554L, 936L, 892L, 433L, 1560L,
697L, 1791L, 1755L, 2351L, 720L, 740L, 1558L, 674L, 1736L, 988L,
321L, 18L, 375L, 959L, 2560L, 1047L, 2429L, 119L, 2468L, 98L,
773L, 1158L, 2520L, 1216L, 1872L, 2364L, 2094L, 1035L, 826L,
2374L, 1028L, 2368L, 176L, 895L, 2090L, 399L, 1789L, 179L, 1800L,
369L, 2568L, 140L, 1207L, 1001L, 518L, 481L, 12L, 2597L, 1474L,
2749L, 2097L, 379L, 2110L, 1615L, 800L, 423L, 2733L, 626L, 662L,
421L, 1363L, 898L, 530L, 2315L, 1365L, 2331L, 468L, 768L, 900L,
2027L, 544L, 1337L, 2376L, 53L, 44L, 2338L, 2075L, 2655L, 78L,
1782L, 1231L, 2291L, 1379L, 212L, 2212L, 1032L, 1929L, 331L,
790L, 1226L, 664L, 1018L, 2735L, 916L, 1157L, 590L, 1343L, 7L,
490L, 2257L, 1853L, 2251L, 1748L, 719L, 1941L, 1885L, 1544L,
725L, 1294L, 1494L, 2601L, 1077L, 1169L, 979L, 709L, 2282L, 1526L,
1797L, 1424L, 1690L, 993L, 1979L, 1268L, 730L, 1739L, 2697L,
1842L, 952L, 2483L, 479L, 864L, 2677L, 283L), class = "data.frame")
Starting value
starting_value <- structure(c(0.177698291502873, 0.6, 0.0761564106440883, 0.05,
1.9, 1.1, 0.877181493020499, 1.9), .Names = c("F_initial_x2",
"F_decay_x2", "S_initial_x2", "S_decay_x2", "initial_x1", "decay_x1",
"initial_x3", "decay_x3"))
NLSLM fail
coef(nlsLM(
formula = y ~ (F_initial_x2 * exp(- F_decay_x2 * x2) + S_initial_x2 * exp(- S_decay_x2 * x2)) *
(1 + initial_x1 * exp(- decay_x1 * x1)) *
(1 + initial_x3 * exp(- decay_x3 * x3 )),
data = df,
start = coef(brute_force),
lower = c(0, 0, 0, 0, 0, 0, 0, 0),
control = nls.lm.control(maxiter = 200),
trace = T))
It. 0, RSS = 1.36145, Par. = 0.177698 0.6 0.0761564 0.05 1.9 1.1 0.877181 1.9
It. 1, RSS = 1.25401, Par. = 0.207931 0.581039 0.0769047 0.0577244 2.01947 1.22911 0.772957 5.67978
It. 2, RSS = 1.19703, Par. = 0.188978 0.604515 0.0722749 0.0792141 2.44179 1.1258 0.96305 8.67253
It. 3, RSS = 1.1969, Par. = 0.160885 0.640958 0.0990201 0.145187 3.5853 0.847158 0.961844 13.2183
It. 4, RSS = 1.19057, Par. = 0.142138 0.685678 0.11792 0.167417 4.27977 0.936981 0.959606 13.2644
It. 5, RSS = 1.19008, Par. = 0.124264 0.757088 0.136277 0.188896 4.76578 0.91274 0.955142 21.0167
It. 6, RSS = 1.18989, Par. = 0.118904 0.798296 0.141951 0.194167 4.93099 0.91529 0.952972 38.563
It. 7, RSS = 1.18987, Par. = 0.115771 0.821874 0.145398 0.197773 5.02251 0.914204 0.949906 38.563
It. 8, RSS = 1.18986, Par. = 0.113793 0.837804 0.147573 0.199943 5.07456 0.914192 0.948289 38.563
It. 9, RSS = 1.18986, Par. = 0.112458 0.848666 0.149033 0.201406 5.11024 0.914099 0.947232 38.563
It. 10, RSS = 1.18986, Par. = 0.111538 0.856282 0.150035 0.202411 5.13491 0.914051 0.946546 38.563
It. 11, RSS = 1.18986, Par. = 0.110889 0.861702 0.15074 0.203118 5.15244 0.914013 0.946076 38.563
It. 12, RSS = 1.18986, Par. = 0.110426 0.865606 0.151243 0.203623 5.16501 0.913986 0.945747 38.563
It. 13, RSS = 1.18986, Par. = 0.110092 0.868441 0.151605 0.203986 5.17412 0.913966 0.945512 38.563
It. 14, RSS = 1.18986, Par. = 0.109849 0.87051 0.151868 0.20425 5.18075 0.913952 0.945343 38.563
It. 15, RSS = 1.18985, Par. = 0.109672 0.872029 0.15206 0.204443 5.18561 0.913941 0.94522 38.563
It. 16, RSS = 1.18985, Par. = 0.109542 0.873147 0.152201 0.204585 5.18918 0.913933 0.945131 38.563
It. 17, RSS = 1.18985, Par. = 0.109446 0.873971 0.152305 0.204689 5.19181 0.913927 0.945065 38.563
Error in nlsModel(formula, mf, start, wts) :
singular gradient matrix at initial parameter estimates
Questions:
Does it make sense to use the best parameters found before the singular gradient matrix problem, ie the one found at Iteration = 17?
If yes is there a way to fetch them? I didn't succeed to save the results when an error occured.
I've noticed that if I reduce the number of maxiter to a number below 17 I still have the same error which appear in the new last iteration, which doesn't make sense to me
Eg with maxiter = 10
It. 0, RSS = 1.36145, Par. = 0.177698 0.6 0.0761564 0.05 1.9 1.1 0.877181 1.9
It. 1, RSS = 1.25401, Par. = 0.207931 0.581039 0.0769047 0.0577244 2.01947 1.22911 0.772957 5.67978
It. 2, RSS = 1.19703, Par. = 0.188978 0.604515 0.0722749 0.0792141 2.44179 1.1258 0.96305 8.67253
It. 3, RSS = 1.1969, Par. = 0.160885 0.640958 0.0990201 0.145187 3.5853 0.847158 0.961844 13.2183
It. 4, RSS = 1.19057, Par. = 0.142138 0.685678 0.11792 0.167417 4.27977 0.936981 0.959606 13.2644
It. 5, RSS = 1.19008, Par. = 0.124264 0.757088 0.136277 0.188896 4.76578 0.91274 0.955142 21.0167
It. 6, RSS = 1.18989, Par. = 0.118904 0.798296 0.141951 0.194167 4.93099 0.91529 0.952972 38.563
It. 7, RSS = 1.18987, Par. = 0.115771 0.821874 0.145398 0.197773 5.02251 0.914204 0.949906 38.563
It. 8, RSS = 1.18986, Par. = 0.113793 0.837804 0.147573 0.199943 5.07456 0.914192 0.948289 38.563
It. 9, RSS = 1.18986, Par. = 0.112458 0.848666 0.149033 0.201406 5.11024 0.914099 0.947232 38.563
It. 10, RSS = 0.12289, Par. = 0.112458 0.848666 0.149033 0.201406 5.11024 0.914099 0.947232 38.563
Error in nlsModel(formula, mf, start, wts) :
singular gradient matrix at initial parameter estimates
In addition: Warning message:
In nls.lm(par = start, fn = FCT, jac = jac, control = control, lower = lower, :
lmdif: info = -1. Number of iterations has reached `maxiter' == 10.
Do you see any explanation?
The underlying problem in the question is that convergence is not being achieved. This can be resolved by transforming the decay parameters using Y = log(X+1) and then transforming them back afterwards using X = exp(Y)-1. Such transformations can beneficially modify the jacobian. Unfortunately, the application of such transformations tends to be largely trial and error. (Also see Note 1.)
ix <- grep("decay", names(starting_value))
fm <- nlsLM(
formula = y ~ (F_initial_x2 * exp(- log(F_decay_x2+1) * x2) +
S_initial_x2 * exp(- log(S_decay_x2+1) * x2)) *
(1 + initial_x1 * exp(- log(decay_x1+1) * x1)) *
(1 + initial_x3 * exp(- log(decay_x3+1) * x3 )),
data = df,
start = replace(starting_value, ix, exp(starting_value[ix]) - 1),
lower = c(0, 0, 0, 0, 0, 0, 0, 0),
control = nls.lm.control(maxiter = 200),
trace = TRUE)
giving a similar residual sum of squares but achieving convergence:
> fm
Nonlinear regression model
model: y ~ (F_initial_x2 * exp(-log(F_decay_x2 + 1) * x2) + S_initial_x2 * exp(-log(S_decay_x2 + 1) * x2)) * (1 + initial_x1 * exp(-log(decay_x1 + 1) * x1)) * (1 + initial_x3 * exp(-log(decay_x3 + 1) * x3))
data: df
F_initial_x2 F_decay_x2 S_initial_x2 S_decay_x2 initial_x1 decay_x1
1.092e-01 1.402e+00 1.526e-01 2.275e-01 5.199e+00 1.494e+00
initial_x3 decay_x3
9.449e-01 1.375e+07
residual sum-of-squares: 1.19
Number of iterations to convergence: 38
Achieved convergence tolerance: 1.49e-08
> replace(coef(fm), ix, log(coef(fm)[ix]+1))
F_initial_x2 F_decay_x2 S_initial_x2 S_decay_x2 initial_x1 decay_x1
0.1091735 0.8763253 0.1525997 0.2049852 5.1993194 0.9139096
initial_x3 decay_x3
0.9448779 16.4368001
Note 1: After some experimentation I noticed that it was good enough to just apply the transformation on decay_x3.
Note 2: Regarding the comment that you would like something automatic note that a third degree polynomial fit with lm would more consistently not run into trouble and has lower residual sum of squares -- 1.14 vs. 1.19 -- but at the expense of more parameters -- 10 vs. 8.
# lm poly fit
fm.poly <- lm(y ~ poly(x1, x2, degree = 3), df)
deviance(fm.poly) # residual sum of squares
## [1] 1.141398
length(coef(fm.poly)) # no. of coefficients
## [1] 10
# nlsLM fit transforming decay parameters
deviance(fm)
## [1] 1.189855
length(coef(fm))
## [1] 8
Note 3: Here is another model formed by replacing the x3 part with a quadratic polynomial and dropping F_initial_x2 as it becomes redundant. It also has 8 parameters, it converges and it fits the data better than the model in the question (i.e. has lower residual sum of squares).
fm3 <- nlsLM(formula = y ~ (exp(- F_decay_x2 * x2) +
S_initial_x2 * exp(- S_decay_x2 * x2)) *
(1 + initial_x1 * exp(- decay_x1 * x1)) *
cbind(1, poly(x3, degree = 2)) %*% c(p1,p2,p3),
data = df,
start = c(starting_value[-c(1, 7:8)], p1=0, p2=0, p3=0),
lower = c(0, 0, 0, 0, 0, 0, NA, NA),
control = nls.lm.control(maxiter = 200),
trace = TRUE)
giving:
> fm3
Nonlinear regression model
model: y ~ (exp(-F_decay_x2 * x2) + S_initial_x2 * exp(-S_decay_x2 * x2)) * (1 + initial_x1 * exp(-decay_x1 * x1)) * cbind(1, poly(x3, degree = 2)) %*% c(p1, p2, p3)
data: df
F_decay_x2 S_initial_x2 S_decay_x2 initial_x1 decay_x1 p1
3.51614 2.60886 0.26304 8.26244 0.81232 0.09031
p2 p3
-0.16968 0.53324
residual sum-of-squares: 1.019
Number of iterations to convergence: 20
Achieved convergence tolerance: 1.49e-08
Note 4: nlxb from the nlmrt package converges without doing anything special.
library(nlmrt)
nlxb(
formula = y ~ (F_initial_x2 * exp(- F_decay_x2 * x2) + S_initial_x2 * exp(- S_decay_x2 * x2)) *
(1 + initial_x1 * exp(- decay_x1 * x1)) *
(1 + initial_x3 * exp(- decay_x3 * x3 )),
data = df,
start = starting_value,
lower = c(0, 0, 0, 0, 0, 0, 0, 0),
control = nls.lm.control(maxiter = 200),
trace = TRUE)
giving:
residual sumsquares = 1.1899 on 280 observations
after 31 Jacobian and 33 function evaluations
name coeff SE tstat pval gradient JSingval
F_initial_x2 0.109175 NA NA NA 3.372e-11 15.1
F_decay_x2 0.876313 NA NA NA -5.94e-12 8.083
S_initial_x2 0.152598 NA NA NA 6.55e-11 2.163
S_decay_x2 0.204984 NA NA NA 4.206e-11 0.6181
initial_x1 5.19928 NA NA NA -1.191e-12 0.3601
decay_x1 0.91391 NA NA NA 6.662e-13 0.1315
initial_x3 0.944879 NA NA NA 2.736e-12 0.02247
decay_x3 33.9921 NA NA NA -1.056e-15 2.928e-15
Often when this error occurs, the problem is not the code but the used model. A singular gradient matrix at the initial parameter estimates might indicate that there is not a single unique solution for the model or that the model is overspecified for the data at hand.
To answer your questions:
Yes, that makes sense. The function nlsLM first calls nls.lm which does the iteration. When it reaches the end of the iterations (either because of a best fit or because max.iter), the result is passed on to the function nlsModel. That function does a QR decomposition of the gradient matrix multiplied by the squared weights. And your initial gradient matrix contains a column with only zeros. So while nls.lm can do the iterations, it's only at the next step nlsModel that the problem with the gradient matrix is actually checked and discovered.
There is a way, but that requires you to change the options within R itself, specifically the error option. By setting it to dump.frames, you get a dump of all the environments that exist at the time of error. Those are stored in a list called last.dump and you can use these environments to look for the values you want.
In this case the parameters are returned by a function getPars() that resides inside the environment of the workhorse function nlsModel:
old.opt <- options(error = dump.frames)
themod <- nlsLM(
formula = y ~ (F_initial_x2 * exp(- F_decay_x2 * x2) +
S_initial_x2 * exp(- S_decay_x2 * x2)) *
(1 + initial_x1 * exp(- decay_x1 * x1)) *
(1 + initial_x3 * exp(- decay_x3 * x3 )),
data = df,
start = starting_value,
lower = c(0, 0, 0, 0, 0, 0, 0, 0),
control = nls.lm.control(maxiter = 200),
trace = TRUE)
thecoefs <- llast.dump[["nlsModel(formula, mf, start, wts)"]]$getPars()
options(old.opt) # reset to the previous value.
Note that this is NOT the kind of code you want to use in a production environment or to share with colleagues. And it's also not a solution to your problem, because the problem is the model, not the code.
This is another consequence of what I explained in 1. So yes, that's logic.
I've done a very brief test to see if it really is the model, and if I replace the last parameter (decay_x3) by its start value, the model is fitted without problem. I don't know what we're dealing with here, so dropping another parameter might make more sense in the real world, but just to prove that your code is fine:
themod <- nlsLM(
formula = y ~ (F_initial_x2 * exp(- F_decay_x2 * x2) +
S_initial_x2 * exp(- S_decay_x2 * x2)) *
(1 + initial_x1 * exp(- decay_x1 * x1)) *
(1 + initial_x3 * exp(- 1.9* x3 )),
data = df,
start = starting_value[-8],
lower = c(0, 0, 0, 0, 0, 0, 0, 0)[-8],
control = nls.lm.control(maxiter = 200),
trace = TRUE)
exits without errors at iteration 10.
EDIT:
I've been looking a bit deeper into it, and based on the data the "extra" solution is basically to kick x3 out of the model. You only have 3 unique values in there, and the initial estimate for the parameter is about 38. So:
> exp(-38*c(1,2,3)) < .Machine$double.eps
[1] TRUE TRUE TRUE
If you compare that to the actual Y values, it's clear that initial_x3 * exp(- decay_x3 * x3 ) doesn't contribute anything to the model, as it is practically 0.
If you manually calculate the gradient as done in nlsModel, you get a matrix that's not of full rank; the last column contains only 0 :
theenv <- list2env( c(df, thecoefs))
thederiv <- numericDeriv(form[[3]], names(starting_value), theenv)
thegrad <- attr(thederiv, "gradient")
And that's what gives you the error. The model is overspecified for the data you have.
The log-transformation that Gabor suggests, prevents that your last estimate becomes so big it forces x3 out of the model. Due to the log transformation, the algorithm doesn't jump to such extreme values very easily. In order to have the same estimates as with the original model, his decay_x3 should be as high as 3.2e16 to specify the same model (exp(38)). So the log transformation protects you from estimates that force the influence of any variable to 0.
Another side effect of the log transformation is that big steps in the value of decay_x3 have only a moderate effect on the model. The estimate Gabor finds, is already a whopping 1.3e7, but after the back transformation that's still a doable value of 16 for decay_x3. Which still makes x3 redundant in the model if you look at :
> exp(-16*c(1,2,3))
[1] 1.125352e-07 1.266417e-14 1.425164e-21
But it doesn't cause the singularity that causes your error.
You can avoid this by setting your upper boundaries, eg:
themod <- nlsLM(
formula = y ~ (F_initial_x2 * exp(- F_decay_x2 * x2) +
S_initial_x2 * exp(- S_decay_x2 * x2)) *
(1 + initial_x1 * exp(- decay_x1 * x1)) *
(1 + initial_x3 * exp(- decay_x3 * x3 )),
data = df,
start = starting_value,
lower = c(0, 0, 0, 0, 0, 0, 0, 0),
upper = rep(- log(.Machine$double.eps^0.5),8),
control = nls.lm.control(maxiter = 200),
trace = TRUE)
runs perfectly fine, gives you the same estimates, and again concludes that x3 is redundant.
So whatever way you look at it, x3 has no impact on y, your model is overspecified and can't be fit decently with the data at hand.
Related
Why is my dplyr code to create multiple variables using mutate and zoo incredibly slow?
I am using dplyr to create multiple variables in my data frame using mutate. At the same time, I am using zoo to calculate a rolling average. As an example, I have my variables set up like so:
vars <- "total_apples", "total_oranges", "total_bananas"
My data has over 100 variables and approx. 40,000 lines, but the above is just an example.
I am using this code below:
library(dplyr)
library(zoo)
data <- data %>%
group_by(fruit) %>%
mutate(across(c(all_of(vars)), list(avge_last2 = ~ zoo::rollapplyr(., 2, FUN = mean, partial = TRUE))))
Just for the above to calculate the average over the last 2 records, it takes over 5 mins:
> end.time <- Sys.time()
> time.taken <- end.time - start.time
> time.taken
Time difference of 5.925337 mins
It takes even longer if I want to average over more records, say n= 10 like so:
library(dplyr)
library(zoo)
data <- data %>%
group_by(fruit) %>%
mutate(across(c(all_of(vars)), list(avge_last2 = ~ zoo::rollapplyr(., 10, FUN = mean, partial = TRUE))))
Is there an issue with my code or is it something else?
dput(head(data,20)) provides the following:
structure(list(match_id = c(14581L, 14581L, 14581L, 14581L, 14581L,
14581L, 14581L, 14581L, 14581L, 14581L, 14581L, 14581L, 14581L,
14581L, 14581L, 14581L, 14581L, 14581L, 14581L, 14581L), match_date = structure(c(16527,
16527, 16527, 16527, 16527, 16527, 16527, 16527, 16527, 16527,
16527, 16527, 16527, 16527, 16527, 16527, 16527, 16527, 16527,
16527), class = "Date"), season = c(2015, 2015, 2015, 2015, 2015,
2015, 2015, 2015, 2015, 2015, 2015, 2015, 2015, 2015, 2015, 2015,
2015, 2015, 2015, 2015), match_round = c(1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), home_team = c(3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3), away_team = c(14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14), venue = c(11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 11, 11, 11, 11, 11, 11), venue_name = c("MCG",
"MCG", "MCG", "MCG", "MCG", "MCG", "MCG", "MCG", "MCG", "MCG",
"MCG", "MCG", "MCG", "MCG", "MCG", "MCG", "MCG", "MCG", "MCG",
"MCG"), opponent = c(14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14), player_id = c(11186L,
11215L, 11285L, 11330L, 11380L, 11388L, 11407L, 11472L, 11473L,
11490L, 11553L, 11561L, 11573L, 11582L, 11598L, 11601L, 11616L,
11643L, 11671L, 11737L), player_first_name = c("Chris", "Chris",
"Kade", "Troy", "Andrew", "Brett", "Cameron", "Marc", "Dale",
"Ivan", "Bryce", "Shane", "Bachar", "Jack", "Andrejs", "Shaun",
"Michael", "Lachie", "Trent", "Alex"), player_last_name = c("Judd",
"Newman", "Simpson", "Chaplin", "Carrazzo", "Deledio", "Wood",
"Murphy", "Thomas", "Maric", "Gibbs", "Edwards", "Houli", "Riewoldt",
"Everitt", "Grigg", "Jamison", "Henderson", "Cotchin", "Rance"
), player_team = c("Carlton", "Richmond", "Carlton", "Richmond",
"Carlton", "Richmond", "Carlton", "Carlton", "Carlton", "Richmond",
"Carlton", "Richmond", "Richmond", "Richmond", "Carlton", "Richmond",
"Carlton", "Carlton", "Richmond", "Richmond"), player_team_numeric = c(3,
14, 3, 14, 3, 14, 3, 3, 3, 14, 3, 14, 14, 14, 3, 14, 3, 3, 14,
14), guernsey_number = c(5L, 1L, 6L, 25L, 44L, 3L, 36L, 3L, 39L,
20L, 4L, 10L, 14L, 8L, 33L, 6L, 40L, 23L, 9L, 18L), player_position = c(3,
14, 14, 1, 17, 13, 16, 12, 20, 16, 14, 5, 10, 8, 13, 14, 6, 7,
3, 2), disposals = c(21L, 7L, 21L, 13L, 18L, 18L, 11L, 21L, 1L,
13L, 26L, 21L, 21L, 17L, 18L, 17L, 8L, 10L, 17L, 18L), kicks = c(16L,
6L, 13L, 9L, 9L, 9L, 8L, 9L, 1L, 8L, 15L, 9L, 15L, 13L, 14L,
9L, 4L, 9L, 6L, 9L), marks = c(5L, 1L, 8L, 1L, 2L, 3L, 2L, 2L,
0L, 4L, 4L, 1L, 5L, 8L, 8L, 4L, 2L, 6L, 3L, 4L), handballs = c(5L,
1L, 8L, 4L, 9L, 9L, 3L, 12L, 0L, 5L, 11L, 12L, 6L, 4L, 4L, 8L,
4L, 1L, 11L, 9L), tackles = c(6L, 1L, 2L, 2L, 2L, 0L, 1L, 2L,
0L, 4L, 4L, 3L, 1L, 0L, 2L, 2L, 1L, 2L, 1L, 0L), clearances = c(6L,
0L, 0L, 0L, 6L, 1L, 6L, 4L, 0L, 4L, 4L, 7L, 0L, 0L, 1L, 3L, 0L,
0L, 1L, 1L), brownlow_votes = c(0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L), effective_disposals = c(15L,
6L, 16L, 11L, 16L, 13L, 6L, 14L, 1L, 11L, 13L, 16L, 16L, 10L,
14L, 12L, 5L, 6L, 9L, 17L), disposal_efficiency_percentage = c(71L,
86L, 76L, 85L, 89L, 72L, 55L, 67L, 100L, 85L, 50L, 76L, 76L,
59L, 78L, 71L, 63L, 60L, 53L, 94L), contested_possessions = c(11L,
3L, 5L, 7L, 9L, 6L, 7L, 9L, 1L, 9L, 9L, 15L, 1L, 7L, 3L, 4L,
3L, 4L, 5L, 5L), uncontested_possessions = c(10L, 4L, 17L, 6L,
10L, 12L, 4L, 12L, 0L, 4L, 17L, 7L, 18L, 9L, 14L, 11L, 5L, 7L,
12L, 14L), time_on_ground_percentage = c(79L, 65L, 73L, 100L,
76L, 69L, 89L, 81L, 1L, 88L, 73L, 83L, 85L, 98L, 95L, 81L, 96L,
91L, 86L, 96L), afl_fantasy_score = c(93L, 26L, 97L, 42L, 54L,
53L, 61L, 67L, 4L, 91L, 96L, 67L, 78L, 89L, 80L, 80L, 30L, 54L,
54L, 58L), contested_marks = c(0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L,
0L, 2L, 1L, 0L, 1L, 3L, 0L, 0L, 0L, 1L, 0L, 0L), metres_gained = c(474L,
231L, 269L, 165L, 128L, 181L, 151L, 227L, -7L, 160L, 466L, 332L,
709L, 268L, 464L, 283L, 99L, 257L, 203L, 288L), turnovers = c(5L,
3L, 4L, 2L, 3L, 2L, 2L, 4L, 0L, 1L, 6L, 2L, 5L, 8L, 5L, 2L, 2L,
3L, 3L, 1L), effective_kicks = c(11L, 5L, 9L, 7L, 7L, 4L, 3L,
5L, 1L, 6L, 5L, 4L, 11L, 7L, 12L, 5L, 2L, 6L, 1L, 9L), ground_ball_gets = c(8L,
2L, 4L, 5L, 7L, 4L, 4L, 8L, 0L, 3L, 6L, 9L, 0L, 4L, 3L, 2L, 2L,
2L, 5L, 3L), cum_rec = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
13, 14, 15, 16, 17, 18, 19, 20), rank_match_kicks = c(2, 34,
10.5, 20.5, 20.5, 20.5, 28, 20.5, 43, 28, 4.5, 20.5, 4.5, 10.5,
8, 20.5, 39.5, 20.5, 34, 20.5), rank_match_marks = c(14, 39,
5, 39, 33, 27.5, 33, 33, 43.5, 20.5, 20.5, 39, 14, 5, 5, 20.5,
33, 10, 27.5, 20.5)), row.names = c(NA, -20L), class = c("tbl_df",
"tbl", "data.frame"))
Update:
Consider the example below using the functions suggested in the answer below:
match_id <- c("match_1", "match_1","match_1","match_2","match_2","match_2","match_3","match_3","match_3")
player_id <- c("player_1", "player_2", "player_3", "player_1", "player_2", "player_3", "player_1", "player_2", "player_3")
turnovers <- c(5,10,15,1,2,3,5,7,9)
data <- data.frame(match_id, player_id, turnovers)
f <- function(dt, window, vars, byvars, partial=F) {
res = dt[, lapply(.SD, frollmean, n=window), by=byvars, .SDcols=vars]
if(partial) {
res = rbind(
partials(dt,window-1,vars, byvars),
res[window:.N, .SD, by=byvars]
)
}
return(res)
}
partials <- function(dt,w,vars,byvars) {
rbindlist(lapply(1:w, function(p) {
dt[1:p, lapply(.SD, function(v) Reduce(`+`, shift(v,0:(p-1)))/p),
.SDcols = vars, by=byvars][p:.N, .SD, by=byvars]
}))
}
# set the data as data.table
setDT(data)
# define vars of interest
vars = c("turnovers")
# ensure the order is correct for rolling mean
setorder(data, player_id, match_id )
# set the window size
n=3
# get the rolling mean, by grouping variable, for each var in `vars`, and add the partials
f(data, window=n, vars=vars, byvars="player_id", partial=T)
This returns the following:
player_id turnovers
1: player_1 5.000000
2: player_1 3.000000
3: player_1 3.666667
4: player_2 NA
5: player_2 NA
6: player_2 6.333333
7: player_3 NA
8: player_3 NA
9: player_3 9.000000
What am I doing wrong?
You could try this:
library(data.table)
setDT(data)
data[,paste0(vars, "_avge_last2_"):= lapply(.SD, frollmean, n=2),
.SDcols=vars,
by=.(fruit)
]
Update
Here is a more generalized solution for handling the NA(s) at the top of each window (i.e. the partial windows)
First, start with a function that can take a data table (dt), a window size (window), a set of variables (vars), and a set of grouping variables (byvars), and an optional logical indicator partial
f <- function(dt, window, vars, byvars, partial=F) {
res = dt[, lapply(.SD, frollmean, n=window), by=byvars, .SDcols=vars]
if(partial) {
res = rbind(
partials(dt,window-1,vars, byvars),
res[,.SD[window:.N], by=byvars]
)
}
return(res)
}
Add, the optional function partials()
partials <- function(dt,w,vars,byvars) {
rbindlist(lapply(1:w, function(p) {
dt[, lapply(.SD[1:p], function(v) Reduce(`+`, shift(v,0:(p-1)))/p),
.SDcols = vars, by=byvars][, .SD[p:.N], by=byvars]
}))
}
Apply the function
# set the data as data.table
setDT(data)
# define vars of interest
vars = c("turnovers", "effective_kicks")
# ensure the order is correct for rolling mean
setorder(data, match_id, player_id)
# set the window size
n=3
# get the rolling mean, by grouping variable, for each var in `vars`, and add the partials
f(data, window=n, vars=vars, byvars="player_id", partial=T)
There are several problems:
the code in the question does not work with the data provided but rather it gives errors. There is no fruit column in the data and the vars columns don't exist either. To make it run we group by match_id and define vars to include some existing columns.
it is better not to overwrite data but rather use a different name for the output to make debugging easier.
using across causes rollapplyr to be applied separately for each column which is inefficient given that rollapply can process multiple columns at once.
Using columns that actually exist in the data provided and assuming we want to use rollapplyr on the columns named in vars try this which only runs rollapplyr once per group and seems slightly faster.
Also fill=NA is used in place of partial=TRUE it will use a somewhat faster algorithm; however, in that case the first row in each group will have NA's as that is what fill=NA means and also that algorithm won't be used if there are already NA's in the columns to be averaged.
library(dplyr)
library(zoo)
vars <- c("home_team", "away_team")
data_out <- data %>%
group_by(match_id) %>%
data.frame(avg = rollapplyr(.[vars], 2, mean, partial = TRUE)) %>%
ungroup
I find that processing grouped dataframes in dplyer can really slows things down, I'm not sure if it's the best workaround but when I finish grouping I pipe in %>% as.data.frame() to get rid of the grouping information, and then do my calculations afterward. It can save a lot of time. If you've previously grouped a large dataset give that a try.
Inconsistent predictions from predict.gbm() 2.1.4 vs 2.1.3
This question is related to my earlier post here.
I have tracked down the problem and it seems to be related to which version of gbm I use. The latest version, 2.1.4 exhibits the problem on my system (R 3.4.4 and also 3.5; both on Ubuntu 18.04) whereas version 2.1.3 works as expected:
mydata <- structure(list(Count = c(1L, 3L, 1L, 4L, 1L, 0L, 1L, 2L, 0L, 0L, 1L, 1L, 2L, 1L, 2L, 2L, 1L, 2L, 0L, 2L, 3L, 1L, 4L, 3L, 0L, 4L, 1L, 2L, 1L, 1L, 0L, 2L, 1L, 4L, 1L, 5L, 3L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 2L, 0L, 0L, 1L, 1L, 1L, 0L, 3L, 1L, 1L, 0L, 3L, 1L, 1L, 1L, 1L, 2L, 3L, 2L, 2L, 0L, 0L, 3L, 5L, 1L, 2L, 1L, 1L, 0L, 0L, 1L, 2L, 1L, 3L, 1L, 1L, 0L, 2L, 2L, 1L, 3L, 3L, 2L, 0L, 0L, 1L, 2L, 1L, 0L, 2L, 0L, 0L, 4L, 4L, 2L), Treat1 = structure(c(10L, 14L, 8L, 2L, 3L, 12L, 1L, 10L, 6L, 2L, 11L, 11L, 15L, 1L, 8L, 3L, 13L, 9L, 9L, 11L, 1L, 8L, 14L, 5L, 10L, 8L, 15L, 11L, 7L, 6L, 13L, 11L, 7L, 1L, 1L, 2L, 7L, 12L, 5L, 1L, 8L, 1L, 9L, 8L,12L, 14L, 12L, 7L, 8L, 14L, 3L, 3L, 5L, 1L, 1L, 11L, 6L, 5L, 5L, 13L, 9L, 3L, 8L, 9L, 13L, 9L, 7L, 9L, 2L, 6L, 10L, 3L, 11L, 4L, 3L, 15L, 12L, 6L, 4L, 3L, 8L, 8L, 11L, 1L, 11L, 2L, 11L, 5L, 12L, 6L, 8L, 14L, 1L, 9L, 9L, 10L, 10L, 5L, 14L, 3L), .Label = c("D", "U", "R", "E", "C", "Y", "L", "O", "G", "T", "N", "J", "V", "X", "A"), class = "factor"), Treat2 = structure(c(15L, 13L, 7L, 8L, 2L, 5L, 15L, 4L, 2L, 7L, 6L, 2L, 3L, 14L, 10L, 7L, 7L, 14L, 11L, 7L, 6L, 1L, 5L, 13L, 11L, 6L, 10L, 5L, 3L, 1L, 7L, 9L, 6L, 10L, 5L, 11L, 15L, 9L, 7L, 11L, 10L, 2L, 3L, 3L, 5L, 11L, 8L, 6L,4L, 5L, 15L, 8L, 8L, 2L, 2L, 10L, 4L, 1L, 10L, 11L, 10L, 8L, 7L, 7L, 8L, 14L, 16L, 11L, 10L, 9L, 3L, 15L, 13L, 1L, 11L, 11L, 9L, 7L, 10L, 9L, 3L, 7L, 5L, 13L, 3L, 14L, 10L, 10L, 15L, 13L, 15L, 12L, 14L, 11L, 5L, 4L, 2L, 3L, 11L, 10L), .Label = c("B", "X", "R", "H", "L", "D", "U", "Q", "K", "C", "T", "V", "J", "E", "F", "A"), class = "factor"), Near = c(0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 0, 1, 0, 0), Co1 = c(2, 5, 1, 1, 0, 1, 1, 2, 1, 2, 5, 2, 1, 0, 1, 2, 6, 3, 3, 1, 2, 2, 3, 0, 1, 0, 1, 0, 2, 1, 0, 1, 2, 3, 1, 2, 2, 0, 0, 2, 3, 3, 1, 1, NA, 2, 0, 2, 1, NA, 1, 1, 0, 1, 2, 0, 2, 1, 1, 1, 2, 3, 1, 0, 4, 0, 0, 0, 2, 2, 1, 1,2, 0, 1, 2, 1, 0, 0, 0, 0, 2, 1, 2, 2, 2, 2, 1, 0, 1, 1, 1, 1, 1, 0, 2, 0, 0, 5, 1), Co2 = c(1, 1, 2, 2, 4, 1, 3, 0, 5, 2, 2, 4, 1, 1, 2, 1, 2, 3, 0, 2, 3, 3, 0, 3, 1, 0, 1, 1, 1, 2, 0, 1, 1, 1, 2, 3, 2, 2, 3, 0, 0, 0, 1, 2, NA, 1, 1, 1, 0, 2, 1, 1, 2, 5, 0, 2, 1, 4, 1, 1, 3, 0, 1, 1, 1, 1, NA, 0, 2, 1, 1, 3, 2, 1, 2, 1, 3, 1, 2, 0, 1, 5, 2, 2, 1, 2, 3, 4, 3, 1, 1, 0, 5, 1, 1, 0, 1, 1, 2, 0)), .Names = c("Count", "Treat1", "Treat2", "Near", "Co1", "Co2"), row.names = c(1759L, 959L, 1265L, 1504L, 630L, 1905L, 1885L, 1140L, 1187L, 1792L, 1258L, 1125L, 756L, 778L, 1718L, 1797L, 388L, 715L, 63L, 311L, 1492L, 1128L, 629L, 536L, 503L, 651L, 1684L, 1893L, 721L, 1440L, 1872L, 1444L, 1593L, 143L, 1278L, 1558L, 1851L, 1168L, 1829L, 386L, 365L, 849L, 429L, 155L, 11L, 1644L, 101L, 985L, 72L, 459L, 1716L, 844L, 1313L, 77L, 1870L, 744L, 219L, 513L, 644L, 831L, 338L, 284L, 211L, 1096L,243L, 1717L, 1881L, 1784L, 1017L, 992L, 45L, 707L, 489L, 1267L, 1152L, 1819L, 995L, 510L, 1350L, 1700L, 56L, 1754L, 725L, 1625L, 319L, 1818L, 1287L, 1634L, 953L, 1351L, 1787L, 923L, 917L, 484L, 886L, 390L, 1531L, 679L, 1811L, 1736L), class = "data.frame")
detach("package:gbm", unload = TRUE )
remove.packages("gbm")
require(devtools)
install_version("gbm", version = "2.1.3")
set.seed(12345)
require(gbm)
n.trees <- 10000
m1.gbm <- gbm(Count ~ Treat1 + Treat2 + Near + Co1 + Co2, data = mydata, distribution = "poisson", n.trees = n.trees)
head(predict(m1.gbm, newdata = mydata, n.trees = n.trees, type = "response"))
[1] 0.8620154 2.8210216 0.8800267 3.7808341 0.4749737 0.3716022
predict(m1.gbm, newdata = head(mydata), n.trees = n.trees, type = "response")
[1] 0.8620154 2.8210216 0.8800267 3.7808341 0.4749737 0.3716022
...as expected. However,
detach("package:gbm", unload = TRUE )
remove.packages("gbm")
install.packages("gbm", dependencies = TRUE)
# I had to restart R after this, otherwise the following line failed with:
# Loading required package: gbm
# Error: package or namespace load failed for ‘gbm’ in get(method, envir = home):
# lazy-load database '/home/container/R/x86_64-pc-linux-gnu-library/3.5/gbm/R/gbm.rdb' is corrupt
require(gbm)
m1.gbm <- gbm(Count ~ Treat1 + Treat2 + Near + Co1 + Co2, data = mydata, distribution = "poisson", n.trees = n.trees)
head(predict(m1.gbm, newdata = mydata, n.trees = n.trees, type = "response"))
[1] 0.7524109 2.8789957 0.7843470 4.1724821 0.4525449 0.2036923
predict(m1.gbm, newdata = head(mydata), n.trees = n.trees, type = "response")
[1] 2.2216079 1.2806235 0.9109426 2.2842149 2.4828922 0.6124778
...which exhibits the problem in my earlier post.
I find this quite surprising since gbm is a well-known package, although I see that the vignette was update last month, so perhaps the latest version was only recently released. I was unable to find the exact date from here. What is the best way to proceed here ?
r geom_bar reorder layers of bars by values
I have produced a bar chart that shows cumulative totals over periods of months for various programs using the following data structure and code:
library(dplyr)
data_totals <- data_long %>%
group_by(Period, Program) %>%
arrange(Period, Program) %>%
ungroup() %>%
group_by(Program) %>%
mutate(Running_Total = cumsum(Value))
dput(data_totals)
structure(list(Period = structure(c(1L, 1L, 1L, 1L, 1L, 2L, 2L,
2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 5L, 5L, 5L,
5L, 5L, 6L, 6L, 6L, 6L, 6L, 7L, 7L, 7L, 7L, 7L, 8L, 8L, 8L, 8L,
8L, 9L, 9L, 9L, 9L, 9L, 10L, 10L, 10L, 10L, 10L, 11L, 11L, 11L,
11L, 11L, 12L, 12L, 12L, 12L, 12L), .Label = c("2018-04", "2018-05",
"2018-06", "2018-07", "2018-08", "2018-09", "2018-10", "2018-11",
"2018-12", "2019-01", "2019-02", "2019-03", "Apr-Mar 2019"), class = "factor"),
Program = structure(c(1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L,
5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L,
5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L,
5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L,
5L, 1L, 2L, 3L, 4L, 5L), .Label = c("A",
"B", "C", "D",
"E"), class = "factor"), Value = c(5597,
0, 0, 0, 1544, 0, 0, 0, 0, 1544, 0, 0, 0, 0, 1544, 0, 0,
850, 0, 1544, 0, 0, 0, 0, 1544, 0, 0, 0, 0, 1544, 0, 0, 0,
0, 1544, 0, 0, 0, 0, 1544, 0, 0, 0, 0, 1544, 0, 0, 0, 0,
1544, 0, 0, 0, 0, 1544, 0, 0, 0, 0, 1544), Running_Total = c(5597,
0, 0, 0, 1544, 5597, 0, 0, 0, 3088, 5597, 0, 0, 0, 4632,
5597, 0, 850, 0, 6176, 5597, 0, 850, 0, 7720, 5597, 0, 850,
0, 9264, 5597, 0, 850, 0, 10808, 5597, 0, 850, 0, 12352,
5597, 0, 850, 0, 13896, 5597, 0, 850, 0, 15440, 5597, 0,
850, 0, 16984, 5597, 0, 850, 0, 18528)), .Names = c("Period",
"Program", "Value", "Running_Total"), class = c("grouped_df",
"tbl_df", "tbl", "data.frame"), row.names = c(NA, -60L), vars = "Program", labels = structure(list(
Program = structure(1:5, .Label = c("A",
"B", "C", "D",
"E"), class = "factor")), class = "data.frame", row.names = c(NA,
-5L), vars = "Program", drop = TRUE, .Names = "Program"), indices = list(
c(0L, 5L, 10L, 15L, 20L, 25L, 30L, 35L, 40L, 45L, 50L, 55L
), c(1L, 6L, 11L, 16L, 21L, 26L, 31L, 36L, 41L, 46L, 51L,
56L), c(2L, 7L, 12L, 17L, 22L, 27L, 32L, 37L, 42L, 47L, 52L,
57L), c(3L, 8L, 13L, 18L, 23L, 28L, 33L, 38L, 43L, 48L, 53L,
58L), c(4L, 9L, 14L, 19L, 24L, 29L, 34L, 39L, 44L, 49L, 54L,
59L)), drop = TRUE, group_sizes = c(12L, 12L, 12L, 12L, 12L
), biggest_group_size = 12L)
# reorder the groups descending so that the lowest total will be on layers from front to back
reorder(data_totals$Program, -data_totals$Running_Total)
ggplot(data = data_totals, aes(x = Period, y = Running_Total)) +
geom_bar(aes(color = Program, group = Program, fill = Program),
stat = "identity", position = "identity", alpha = 1.0)
It works in that it creates the graph with all the proper data, but the smaller Running_Totals are obscured by the larger ones.
I get the following error message as well:
Warning message:
The plyr::rename operation has created duplicates for the following name(s): (`colour`)
Even though I do not have the plyr package loaded.
I can see all the Running_Totals if I set the alpha to 0.5
Running_Total for each Program by Period, alpha = 0.5:
How can I get the layers ordered so that the smallest values are on the front most layers working back toward the highest values?
The way I was trying to represent the data in the original question was flawed. There is no advantage to having the Program with the maximum value for each Period be the top of the bar. A more illustrative solution is to have a stacked bar, with labels indicating the contribution of each Program to the overall value of each Period: ggplot(data = data_totals[which(data_totals$Running_Total > 0),], aes(x = Period, y = Running_Total, fill = Program)) + geom_bar(aes(color = Program, group = Program, fill = Program), stat = "identity", position = "stack", alpha = 1.0) + geom_text(aes(label = Running_Total), position = position_stack(vjust = 0.5)) I used [which(data_totals$Running_Total > 0),] to eliminate any "0" bars and labels.
Trouble with GLMM with glmer in R: Error in pwrssUpdate...halvings failed to reduce deviance in pwrssUpdate
Here's a snipped of randomly selected data from my full dataframe:
canopy<-structure(list(Stage = structure(c(6L, 5L, 3L, 6L, 7L, 5L, 4L,
7L, 2L, 7L, 5L, 1L, 1L, 4L, 3L, 6L, 5L, 7L, 4L, 4L), .Label = c("milpa",
"robir", "jurup che", "pak che kor", "mehen che", "nu kux che",
"tam che"), class = c("ordered", "factor")), ID = c(44L, 34L,
18L, 64L, 54L, 59L, 28L, 51L, 11L, 56L, 33L, 1L, 7L, 25L, 58L,
48L, 36L, 51L, 27L, 66L), Sample = c(4L, 2L, 2L, 10L, 6L, 9L,
4L, 3L, 3L, 8L, 1L, 1L, 7L, 1L, 10L, 8L, 4L, 3L, 3L, 10L), Subsample = c(2L,
3L, 4L, 3L, 2L, 1L, 3L, 2L, 4L, 3L, 1L, 3L, 2L, 4L, 1L, 1L, 3L,
1L, 1L, 4L), Size..ha. = c(0.5, 0.5, 0.5, 0.5, 6, 0.5, 0.5, 0.25,
0.5, 6, 1, 1, 0.5, 2, 1, 0.5, 1, 0.25, 0.5, 2), Avg.Subsample.Canopy = c(94.8,
94.8, 97.92, 96.88, 97.14, 92.46, 93.24, 97.4, 25.64, 97.4, 94.8,
33.7, 13.42, 98.18, 85.44, 96.36, 97.4, 95.58, 85.7, 92.2), dec = c(0.948,
0.948, 0.9792, 0.9688, 0.9714, 0.9246, 0.9324, 0.974, 0.2564,
0.974, 0.948, 0.337, 0.1342, 0.9818, 0.8544, 0.9636, 0.974, 0.9558,
0.857, 0.922)), .Names = c("Stage", "ID", "Sample", "Subsample",
"Size..ha.", "Avg.Subsample.Canopy", "dec"), row.names = c(693L,
537L, 285L, 1017L, 853L, 929L, 441L, 805L, 173L, 889L, 513L,
9L, 101L, 397L, 913L, 753L, 569L, 801L, 417L, 1053L), class = "data.frame")
I am trying to code a GLMM of dec as a function of Stage and Size..ha.
The GLMM is necessary because each row represents a point Subsample measured within a larger Sample area. I am also using a binomial distribution given dec are proportional data.
I tried the model:
canopy.binomial.mod<-glmer(dec~Stage*Size..ha.+(1|Sample),family="binomial",data=canopy)
summary(canopy.binomial.mod)
but get the error:
Error in pwrssUpdate(pp, resp, tol = tolPwrss, GQmat = GQmat, compDev
= compDev, : (maxstephalfit) PIRLS step-halvings failed to reduce deviance in pwrssUpdate
I've seen online that this can be a result of needing to scale a predictor variable, so I tried:
cs. <- function(x) scale(x,scale=TRUE,center=TRUE)
canopy.binomial.mod<-glmer(dec~Stage*cs.(Size..ha.)+(1|Sample),family="binomial",data=canopy.rmna)
summary(canopy.binomial.mod)
Which doesn't seem to help. I also thought that maybe I'm asking too much of the model and it's not converging due to too many predictor variables, so let's remove the Size variable, which is of less interest to me.
canopy.binomial.mod<-glmer(dec~Stage+(1|Sample),family="binomial",data=canopy.rmna)
summary(canopy.binomial.mod)
Still no luck. Any ideas how to address this?
Matching colums and rows in a special condition
output1 <- output1 <- structure(list(row = c(1L, 1L, 1L, 1L, 1L, 1L, 2L, 214L, 214L,214L), col = c(17L, 17L, 17L, 17L, 17L, 17L, 16L, 110L, 111L,111L), cell = c(0L, 0L, 0L, 0L, 0L, 0L, 1L, 27244L, 27245L, 27245L), xcoord = c(783750L, 783750L, 783750L, 783750L, 783750L, 783750L,783725L, 786075L, 786100L, 786100L), ycoord = c(187050L, 187050L,187050L, 187050L, 187050L, 187050L, 187025L, 181725L, 181725L,181725L), species = structure(c(1L, 1L, 1L, 8L, 9L, 11L, 1L,3L, 3L, 3L), .Label = c("abiealba", "alnuinca", "alnuviri", "betupend","betupube", "fagusilv", "larideci", "piceabie", "pinucemb", "pinusilv","popunigr", "poputrem", "salicapr", "sorbaucu"), class = "factor"),age = c(100L, 20L, 10L, 100L, 100L, 100L, 100L, 30L, 70L,30L), biomass = c(0.1015, 0.0152, 0.0127, 0.5391, 0.02, 0.1584,0.1019, 0.0114, 0.0115, 0.0114), stems = c(1L, 10L, 10L,20L, 5L, 3L, 4L, 15L, 2L, 10L), slowGrowth = c(0L, 0L, 0L,0L, 14L, 0L, 0L, 0L, 0L, 0L), DBH = c(17.9273, 8.831, 8.2681,34.9717, 9.7366, 18.9254, 17.9523, 6.6486, 6.6793, 6.6486), height = c(14.0924, 8.0258, 7.625, 23.4468, 8.0478, 13.6345,14.1081, 3.6519, 3.6552, 3.6519), availableLight = c(0.0934,0.0807, 0.071, 0.4742, 0.0887, 0.101, 0.0985, 0.958, 0.9952,0.9624), light_rf = c(0.2619, 0.2067, 0.1708, 0.6971, 0.063,0.1049, 0.2896, 0.9768, 0.9972, 0.9793), LeafArea = c(5.4506,5.4506, 5.4506, 5.4506, 5.4506, 5.4506, 5.2884, 0.2307, 0.1732,0.1732), nitorgen_rf = c(0, 0, 0, 0, 0.1328, 0, 0, 0, 0,0), droughtIndex = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), moisture_rf = c(1,1, 1, 1, 1, 1, 1, 1, 1, 1), degreeDay_rf = c(0.258, 0.258,0.258, 0.4726, 0.5144, 0.237, 0.258, 0.1125, 0.1125, 0.1125), foliageWght = c(0.0093, 0.0031, 0.0028, 0.0265, 0.0036,0.0023, 0.0094, 5e-04, 5e-04, 5e-04), twigWght = c(0.0537,0.0115, 0.0096, 0.0513, 0.0149, 0.0847, 0.0538, 0.0109, 0.011,0.0109), boleWght = c(0.0384, 6e-04, 3e-04, 0.4613, 0.0015,0.0713, 0.0387, 0, 0, 0), deadFoliage = c(0.405, 0.405, 0.405,0.405, 0.405, 0.405, 0.3664, 0.0627, 0.0534, 0.0534), deadTwig = c(0.9887,0.9887, 0.9887, 0.9887, 0.9887, 0.9887, 0.9537, 0.7391, 0.8132,0.8132), deadbole = c(2.3166, 2.3166, 2.3166, 2.3166, 2.3166,2.3166, 2.3947, 0, 0, 0)), .Names = c("row", "col", "cell","xcoord", "ycoord", "species", "age", "biomass", "stems", "slowGrowth","DBH", "height", "availableLight", "light_rf", "LeafArea", "nitorgen_rf","droughtIndex", "moisture_rf", "degreeDay_rf", "foliageWght","twigWght", "boleWght", "deadFoliage", "deadTwig", "deadbole"), row.names = c(1L, 2L, 3L, 4L, 5L, 6L, 7L, 131023L, 131024L,131025L), class = "data.frame")
and
Details <- structure(list(fireID = c(0L, 0L, 0L, 0L, 0L, 0L, 0L, 1052L,1052L, 1052L), decade = c(2L, 2L, 2L, 2L, 2L, 2L, 2L, 100L, 100L,100L), cell = c(14150L, 14321L, 14320L, 14489L, 14323L, 13977L,14492L, 14461L, 14122L, 14123L), row = c(128L, 129L, 129L, 130L,129L, 127L, 130L, 130L, 128L, 128L), column = c(137L, 137L, 136L,135L, 139L, 136L, 138L, 107L, 109L, 110L), biomass = c(0.724241,0.652821, 0.776811, 0.860563, 0.649643, 0.751143, 0.760428, 20.5968,33.6653, 15.1725)), .Names = c("fireID", "decade", "cell", "row","column", "biomass"), row.names = c(1L, 2L, 3L, 4L, 5L, 6L, 7L,12896L, 12897L, 12898L), class = "data.frame")
I want to match these two dataset by rows and cols. Actually, I did it with
aa <- merge.data.frame(Details, output1, by=c("cell","row"))
but the problem is I have many rows in output1 which has same coordinates. However I only want to get one coordinates for each row in my details output.
Any suggestions?
Thanks in advance.
If I understand the question correctly you need something like this:
aa <- aa[!duplicated(aa[c("row", "cell")]), ]
I am removing not unique combinations of row and cell because I would imagine that cell plays a role in your analysis since you use it in the merge. Otherwise:
aa <- aa[!duplicated(aa["row"]), ]