GAM Predictions in R have same curve shape - r

I have a dataframe:
Albedo Year_Since_Burn Summer_SRAD Winter_SRAD
1 397.00 1 17801.70 6589.56
2 289.60 2 18027.20 6633.96
3 615.29 3 17397.10 6952.69
4 258.12 4 17793.63 6627.62
5 139.32 5 17853.00 6675.00
6 463.81 6 17853.00 6675.00
7 532.47 7 17853.00 6675.00
8 300.09 8 17648.00 6890.00
9 118.00 9 17786.13 6724.67
10 238.18 10 18050.13 6916.46
11 439.11 11 18057.20 6893.08
12 366.00 12 17823.00 6618.12
13 441.25 13 17809.50 6673.79
14 450.31 14 17654.40 6849.19
15 275.43 15 17592.80 7202.88
16 147.11 16 17830.20 6672.88
17 285.68 17 18065.13 6897.58
18 309.61 18 17665.80 7036.62
19 264.95 19 18053.47 6867.17
20 125.18 20 17834.40 6661.19
21 289.50 21 17824.00 6684.50
22 293.61 22 17826.90 6681.83
23 368.95 23 17634.55 6914.06
24 563.11 24 17434.23 7043.04
25 434.41 25 17527.60 7070.38
26 199.78 26 17955.40 6704.00
27 153.37 27 17872.70 6637.00
28 287.29 28 17843.20 6659.67
29 173.52 29 17822.93 6616.75
30 239.28 30 17884.00 6580.56
31 292.91 31 17884.00 6580.56
32 323.00 32 18078.70 6758.50
33 282.00 33 18078.70 6758.50
34 237.50 34 17779.10 7303.38
35 225.00 35 17822.80 6617.42
36 237.55 36 17822.80 6617.42
37 247.11 37 17918.50 6695.71
38 336.48 38 17918.50 6695.71
39 290.00 39 17918.50 6695.71
40 248.42 40 17822.80 6617.42
41 304.74 41 17918.50 6695.71
42 311.52 42 17918.50 6695.71
43 281.39 43 17918.50 6695.71
44 234.68 44 17918.50 6695.71
45 297.58 45 17918.50 6695.71
46 265.52 46 17918.50 6695.71
47 186.29 47 17918.50 6695.71
48 291.16 48 17918.50 6695.71
49 185.17 49 17918.50 6695.71
50 288.94 50 17918.50 6695.71
51 269.64 51 17918.50 6695.71
52 255.00 52 17918.50 6695.71
I am fitting a GAM model in R like so:
gam.m1 <- gam(Albedo ~ s(Year_Since_Burn) + s(Summer_SRAD) + s(Winter_SRAD), data=df)
which seems to work fine, and returns result as I would expect.
I have now created some data to predict on. Essentially I randomly selected 2 rows in the original df, duplicated them 52 times each, and then removed the Year_Since_Burn and Albedo columns, and created some new Year_Since_Burn data. So I only manipulated one independent variable. I did this like so:
df <- df[sample(nrow(df), 2),]
df <- df %>% select (-c(Albedo, Year_Since_Burn))
#add an id columns
df$ID <- seq.int(nrow(df))
#loop through each row
for (i in 1:nrow(df)) {
#select each row
grp <- (df[i, ])
#repeat each row 52 times
grp <- grp[rep(seq_len(nrow(grp)), each=52),]
#add a column for year since burn
grp$Year_Since_Burn <- seq.int(nrow(grp))
#select rows to keep
grp <- grp %>% select (c(ID, Year_Since_Burn,Summer_SRAD, Winter_SRAD, Winter_Tavg, Summer_Tavg, PFI, Bulk_Density,
SOC_Content, SOC_Stock, L3_Ecoregion))
#append
combined[[i]] <- grp
}
#concat
final = do.call(rbind, combined)
Now for each unique ID in final I predicted the dependent variable like so:
y_hat <- predict(gam.m1, final)
and then I plotted to look at how the predictions varied with Year_Since_Burn:
final2 <- data.frame(as.array(final$ID), as.array(final$Year_Since_Burn), y_hat2)
names(final2) <- c("ID", 'Year_Since_Burn', "Predicted")
#plot
plots1 <- lapply(split(final2, final2$ID),
function(x)
ggplot(x, aes(x=Year_Since_Burn, y=Predicted)) +
geom_line())
For the output graphs the curves are identical in shape for every prediction, it is just the magnitudes that are shifting. I am not sure if this is what GAMs is supposed to do or if this is an error on my part. This is what the predictions for two different Id's look like:

Related

Convert "yymm" numeric to months since 9101 (Jan 1991)

I have a data set that runs from 1991-01 to 1996-12 in R. In order to calculate some time-dependent metrics on some of the data set, I am trying to have a "months since first entry" column. To do so I need to convert a number like 9107 into 07, 9207 into 12+7=19, and 9301 into 12+12+1=25. Ie, the first two digits specify a full year (12 months), and the last two digits specify months since January (01). How would I go about this?
Thank you!
May be, we can use substr (splitted in multiple lines for more clarity and also as.integer)
yrs <- as.integer(substr(v1, 1, 2))
mths <- as.integer(substr(v1, 3, 4))
mths[mths == 1] <- 0
12 * (yrs - yrs[1]) + mths
#[1] 7 19 24
Or without substr
yrs <- v1 %/% 100
12 * (yrs - yrs[1]) + (v1 %% 100)
data
v1 <- c(9107, 9207, 9301)
Using the substrings.
(as.numeric(substr(x, 2, 2)) - 1)*12 + as.numeric(substr(x, 3, 4)) - 1
# [1] 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
# [24] 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
# [47] 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
# [70] 69 70 71
I believe, 9101 should be 0, since it is the distance of itself.
Data:
x <- c(9101, 9102, 9103, 9104, 9105, 9106, 9107, 9108, 9109, 9110,
9111, 9112, 9201, 9202, 9203, 9204, 9205, 9206, 9207, 9208, 9209,
9210, 9211, 9212, 9301, 9302, 9303, 9304, 9305, 9306, 9307, 9308,
9309, 9310, 9311, 9312, 9401, 9402, 9403, 9404, 9405, 9406, 9407,
9408, 9409, 9410, 9411, 9412, 9501, 9502, 9503, 9504, 9505, 9506,
9507, 9508, 9509, 9510, 9511, 9512, 9601, 9602, 9603, 9604, 9605,
9606, 9607, 9608, 9609, 9610, 9611, 9612)

when you need a Kinhom rather than a Kest?

envelope of the K funcition (and its derivative such as L) is very useful for validating a fitted spatial points process model. for instance, I fit a poisson model for a data J1a2, which is as following:
J1a2.points:
# X.1 X Y
1 1 118.544 1638.445
2 2 325.995 1761.223
3 3 681.625 1553.771
4 4 677.392 1816.261
5 5 986.451 1685.016
6 6 1469.093 1354.787
7 7 1608.805 1625.744
8 8 1994.071 1782.391
9 9 1968.669 1375.955
10 10 2362.403 1337.852
11 11 2701.099 1773.924
12 12 2900.083 1820.495
13 13 2963.588 1668.081
14 14 3412.360 1676.549
15 15 3378.490 1456.396
16 16 3721.420 1464.863
17 17 3823.028 1701.951
18 18 4072.817 1790.859
19 19 4089.751 1388.656
20 20 97.375 715.497
21 21 376.799 1033.025
22 22 563.082 1126.166
23 23 935.647 1206.607
24 24 512.277 486.876
25 25 935.647 757.834
26 26 1409.821 410.670
27 27 1435.223 639.290
28 28 1706.180 1045.726
29 29 1968.669 876.378
30 30 2307.365 711.263
31 31 2624.892 897.546
32 32 2654.528 1236.243
33 33 2857.746 423.371
34 34 3039.795 639.290
35 35 3298.050 707.029
36 36 3111.767 1011.856
37 37 3361.555 1227.775
38 38 4047.414 1185.438
39 39 3569.007 508.045
40 40 4250.632 469.942
41 41 4386.110 872.144
42 42 93.141 237.088
43 43 554.614 186.283
44 44 757.832 148.180
45 45 965.283 220.153
46 46 1723.115 296.360
47 47 1744.283 423.371
48 48 1913.631 203.218
49 49 2167.653 292.126
50 50 2629.126 211.685
51 51 3217.610 283.658
52 52 3827.262 325.996
and:
J1a2.Win<-owin(c(0, 4500.42),c(0, 1917.87))
if you draw evelope for the data with Lest:
library(spatstat)
env.data<-envelope(J1a2, Lest,correction="border",
nsim=19, global=TRUE)
plot(env.data,.-r~r, shade=NULL, legend=FALSE,
xlab=expression(paste("r(",mu,"m)")),ylab="L(r)-r", main = "")
the Lest() curve goes out of the envelope. however, if you use Linhom instead of Lest, you will find the Linhom() are all inside of the envelope.
it seems that this suggest a inhomogenous density kernel of the data. so I use y as covariate in fitting:
poisson.J1a2<-ppm(J1a2~1,Poisson(),correction="border")
y1.J1a2<-ppm(J1a2~y,correction="border")
anova(poisson.J1a2,y.J1a2,test="LR") #p=0.6484
I don't find any evidence of a spatial trend of density along y, or x, or their combinations.
then why the Linhom() outperform the Lest() in this case?
furthermore, when should one decide to use Linhom() instead of Lest?
You should first decide whether or not the intensity can be assumed to be constant. To help you with this you can look at kernel density estimates or do formal tests such as a quadrat test etc. If you decide that the intensity can be assumed to be constant you use Lest() if this is not the case you use Linhom().

Reducing the number of nodes of a tree, to obtain nodes with more than one child node

The following tree:
has been obtained from the following matrix
> mat
7 23 47 41 31
7 23 53 41 31
7 23 53 41 37
7 29 47 41 31
7 29 47 41 37
7 29 53 41 31
7 29 53 41 37
11 29 53 41 31
11 29 53 41 37
taking each columns of 'mat' as a level of the tree. If 'data' is the dataframe where the matrix 'mat' is stored
V1 V2 V3 V4 V5
7 23 47 41 31
7 23 53 41 31
7 23 53 41 37
7 29 47 41 31
7 29 47 41 37
7 29 53 41 31
7 29 53 41 37
11 29 53 41 31
11 29 53 41 37
the code that produces above tree is the following
> data$pathString<-paste("0", data$V1,data$V2,data$V3,data$V4,data$V5,sep = "/")
> p_tree <- as.Node(data)
> export_graph(ToDiagrammeRGraph(p_tree), "tree.png")
I would like to modify the tree as follows: (1) if a node at level 'n', labelled by number x, has only one child node at level 'n+1', labelled by number y, then the program brings together these two nodes in one node labelled by the result of the product x*y; 2) if the node at level 'n+1' does not have child nodes, the program does nothing and starts again from another branch; 3) if the node at level 'n+1' has more than one child node, the program apply point (1) and starts again from each of child nodes.
For example, for the tree of our example, the code should:
replace the nodes circled in red with a node labelled by 31*41*47=59737
replace the nodes circled in orange with a node labelled by 53*41=2173
replace the nodes circled in green with a node labelled by 47*41=1927
replace the nodes circled in blue with a node labelled by 11*29*53*41=693187
Try this:
freq <- sapply(1:ncol(data), function(x) {
df <- data[, 1:x, drop = FALSE]
cc <- aggregate(df[, 1], as.list(df), FUN = length)
merge(df, cc, by = colnames(df), sort = FALSE)[, "x"]
})
data$pathString <- sapply(1:nrow(data), function(x) {
g <- 1
for(i in 2:ncol(freq)) g <- c(g,
if(freq[x, i] == freq[x, i - 1]) g[i - 1] else g[i - 1] + 1)
paste0(c("0", tapply(unlist(data[x, , drop = TRUE]), g, prod)), collapse = "/")
})
p_tree <- as.Node(data)
plot(p_tree)

how do I select points in a dataset above x% contour of a density map?

I have a matrix of data (see below) and I am trying to turn it into a density contour map (Can1 and Can2 variables), maybe with ks or sm packages.
My question is how do I select those points in the dataset which lie above (say) 80% contour of the density map?
Thanks
ID Can1 Can2
4 -12.3235137 -1.0788867664
1 -12.2949912 -0.9321009837
5 -12.2835123 -1.0164225574
2 -12.2571822 -0.7094457036
3 -12.2713779 -0.9908419863
10 -12.9870438 -1.0936405526
6 -12.7167605 -1.4620772026
7 -12.8193776 -1.0911349785
8 -12.9781963 -1.1762698594
9 -12.7983478 -1.3453369581
13 -14.0389948 0.2855210115
11 -14.0015922 0.1467552738
15 -14.0723604 0.0244576488
14 -14.0743560 0.1417245145
12 -13.9898266 0.0005437008
20 -6.5881994 0.5124980991
17 -6.1812321 0.6789584579
16 -6.4704200 0.5942317307
18 -6.6960456 0.5720874622
19 -6.1159788 0.5960966790
22 -2.4794887 2.5493267897
24 -2.4918040 2.7823374576
21 -2.5145044 2.5877290160
23 -2.5048371 2.4916280770
25 -2.5018765 2.8536302559
29 -0.1781852 2.0805229401
26 -0.1581308 2.0151355747
28 -0.2118605 1.9658284615
27 -0.4184119 2.0540218901
30 -0.2994573 2.0205573385
35 2.6254869 1.3858705991
31 2.3146430 1.3510499304
33 2.5346138 1.2524229847
34 2.3741699 1.3842499455
32 2.6008389 1.3446707509
37 3.0920503 1.5807032840
38 3.1559727 1.4924092104
36 3.1593556 1.5803284343
39 3.0801444 1.6031732981
40 3.2562384 1.5810975265
43 4.8414364 2.1539254215
41 4.7938193 2.1613978258
44 4.7919209 2.2151527426
42 4.9830802 2.2374622446
45 4.7629268 2.4217335005
46 5.5631728 0.9986762598
50 5.5250403 1.0549399894
48 5.5833619 1.1368625963
47 5.5660312 1.1881215490
49 5.6224256 1.1634998303
53 5.5536366 0.2513665533
54 5.5276808 0.2685455911
51 5.7103045 0.2193839293
52 5.6014729 0.2353172964
55 5.5959034 0.2447836618
56 5.1542133 0.6070006863
59 5.0043394 0.4518710615
58 5.2314146 0.5656457888
60 5.1318728 0.4771275341
57 5.3599822 0.4918185651
61 7.0235173 -0.2669136870
63 7.0216315 -0.0097862523
64 7.0521253 -0.2457722410
62 7.0150637 -0.1456269078
65 7.0729018 -0.3573952321
69 5.8115406 -1.4652084167
67 5.7624475 -1.4147564126
68 5.8692888 -1.4695783153
70 5.9088094 -1.4927034632
66 5.8400205 -1.4817447808
71 4.8586107 -1.3111515744
73 4.7198564 -1.2891991780
72 4.9153659 -1.4499710448
74 4.7653488 -1.2839433419
75 4.7754971 -1.4655359108
77 3.8955675 -7.0922887151
78 3.8338151 -7.1595858283
80 3.7255063 -7.2147373050
79 3.7367055 -7.3468877516
76 4.0166957 -7.1952570639
Calculate the 80% point. One way: y<- x[x > 0.8 * max(x)] (I'm assuming you wanted 80% of the max level, not the 80th percentile) .
Then plot y .
After a bit of searching I think it can be achieved using the kde2d function from the MASS package.

Given data points and y value, give x value

Given a set of (x,y) coordinates, how can I solve for x, from y. If you were to plot the coordinates, they would be non-linear, but pretty close to exponential. I tried approx(), but it is way off. Here is example data. In this scenario, how could I solve for y == 50?
V1 V3
1 5.35 11.7906
2 10.70 15.0451
3 16.05 19.4243
4 21.40 20.7885
5 26.75 22.0584
6 32.10 25.4367
7 37.45 28.6701
8 42.80 30.7500
9 48.15 34.5084
10 53.50 37.0096
11 58.85 39.3423
12 64.20 41.5023
13 69.55 43.4599
14 74.90 44.7299
15 80.25 46.5738
16 85.60 47.7548
17 90.95 49.9749
18 96.30 51.0331
19 101.65 52.0207
20 107.00 52.9781
21 112.35 53.8730
22 117.70 54.2907
23 123.05 56.3025
24 128.40 56.6949
25 133.75 57.0830
26 139.10 58.5051
27 144.45 59.1440
28 149.80 60.0687
29 155.15 60.6627
30 160.50 61.2313
31 165.85 61.7748
32 171.20 62.5587
33 176.55 63.2684
34 181.90 63.7085
35 187.25 64.0788
36 192.60 64.5807
37 197.95 65.2233
38 203.30 65.5331
39 208.65 66.1200
40 214.00 66.6208
41 219.35 67.1952
42 224.70 67.5270
43 230.05 68.0175
44 235.40 68.3869
45 240.75 68.7485
46 246.10 69.1878
47 251.45 69.3980
48 256.80 69.5899
49 262.15 69.7382
50 267.50 69.7693
51 272.85 69.7693
52 278.20 69.7693
53 283.55 69.7693
54 288.90 69.7693
I suppose the problem you have is that approx solves for y given x, while you are talking about solving for x given y. So you need to switch your variables x and y when using approx:
df <- read.table(textConnection("
V1 V3
85.60 47.7548
90.95 49.9749
96.30 51.0331
101.65 52.0207
"), header = TRUE)
approx(x = df$V3, y = df$V1, xout = 50)
# $x
# [1] 50
#
# $y
# [1] 91.0769
Also, if y is exponential with respect to x, then you have a linear relationship between x and log(y), so it makes more sense to use a linear interpolator between x and log(y), then take the exponential to get back to y:
exp(approx(x = df$V3, y = log(df$V1), xout = 50)$y)
# [1] 91.07339

Resources