Related
I have a large dataset and I want to subtract specific columns from each other based on their position. I want to subtract column 2 from column 8, column 3 from column 9 and column 4 from column 10.
Thanks a lot
Magnus
structure(list(Stamp_summertime = structure(c(1546684744, 1546685858,
1546687004, 1547030061, 1547030835, 1547031816), tzone = "UTC", class = c("POSIXct",
"POSIXt")), X26.013 = c(0.138461, 0.138461, 0.138461, 0.144421,
0.144421, 0.144421), X27.024 = c(0.0752111, 0.0752111, 0.0752111,
0.0426819, 0.0426819, 0.0426819), X33.031 = c(3.75788, 3.75788,
3.75788, 3.12581, 3.12581, 3.12581), jar_camp = c("1_pf1.1",
"2_pf1.1", "3_pf1.1", "1_pf2.1", "2_pf2.1", "3_pf2.1"), jar = structure(c(1L,
12L, 23L, 1L, 12L, 23L), .Label = c("1", "10_blank", "11", "12",
"13", "14", "15", "16_blank", "17", "18", "19", "2", "20_blank",
"21", "22", "23", "24", "25", "26", "27", "28", "29", "3", "30_blank",
"31", "32", "33", "34", "35", "36", "37", "38_blank", "39", "4",
"40", "41", "42", "43", "44_blank", "45", "46", "47", "48", "49",
"5_blank", "blank_50", "51", "52", "53", "54", "55", "56", "57",
"6", "7", "8", "9", "X_blank"), class = "factor"), campaign = c("pf1.1",
"pf1.1", "pf1.1", "pf2.1", "pf2.1", "pf2.1"), i.X26.013 = c(0.144658,
0.21502, 0.458296, 0.191571, 0.0789067, 0.711814), i.X27.024 = c(0.0595547,
0.0651149, 0.146772, 0.0997815, 0.0539976, 0.185398), i.X33.031 = c(5.4066,
3.30406, 18.0479, 6.13854, 1.3028, 22.2226)), sorted = "Stamp_summertime", class = c("data.table",
"data.frame"), row.names = c(NA, -6L), .internal.selfref = <pointer: 0x00000237a3d91ef0>)
We can create 2 vectors of position and subtract the columns directly. Since you have data.table we use ..column_number to select columns by position.
library(data.table)
col1group <- 2:4
col2group <- 8:10
df[, ..col1group] - df[, ..col2group])
If you want to add them as new columns to original data you can rename them and cbind
cbind(df, setNames(df[, ..col1group] - df[, ..col2group],
paste0(names(df)[col1group], '_diff')))
Something like the following computes the subtractions in the question.
library(data.table)
nms <- names(df1)
iCols <- grep("^i\\.", nms, value = TRUE)
Cols <- sub("^i\\.", "", iCols)
df1[, lapply(seq_along(Cols), function(i) get(Cols[i]) - get(iCols[i]))]
# V1 V2 V3
#1: -0.0061970 0.0156564 -1.64872
#2: -0.0765590 0.0100962 0.45382
#3: -0.3198350 -0.0715609 -14.29002
#4: -0.0471500 -0.0570996 -3.01273
#5: 0.0655143 -0.0113157 1.82301
#6: -0.5673930 -0.1427161 -19.09679
Following Ronak Shah's answer I realized that the code below also works.
df1[, ..Cols] - df1[, ..iCols]
The numeric results are the same but the column names are the vector Cols.
To create new columns, try
newCols <- paste(Cols, "diff", sep = "_")
df1[, (newCols) := lapply(seq_along(Cols), function(i) get(Cols[i]) - get(iCols[i]))]
Base R solution:
idx <- c(2, 3, 4)
jdx <- c(8, 9, 10)
Using lapply() and column binding the list:
setNames(do.call("cbind", lapply(seq_along(idx), function(i){
df[, jdx[i], drop = FALSE] - df[, idx[i], drop = FALSE]
}
)
), c(paste("x", jdx, idx, sep = "_")))
Using sapply() and coercing vectors to a data.frame:
setNames(data.frame(sapply(seq_along(idx), function(i){
df[, jdx[i], drop = FALSE] - df[, idx[i], drop = FALSE]
}
)
), c(paste("x", jdx, idx, sep = "_")))
Using Map() and Reduce() and column binding to original data.frame:
cbind(df, setNames(Reduce(cbind, Map(function(i){
df[, jdx[i], drop = FALSE] - df[, idx[i], drop = FALSE]
}, seq_along(idx))), c(paste("x", jdx, idx, sep = "_"))))
While trying to optimize and benchmark a function, I was able to shrink 3 for loops into 1 short lapply call, but the function got slower.
I am trying to understand why that happens, as with the 3 loops I preallocate 3 lists with the same length and fill them in 3 different loops, which doesnt seem necessary and inefficient.
## Data #################
Grid = structure(list(ID = 1:81, X = c(99.99922283, 299.99922281, 499.9992228,
699.99922279, 899.99922277, 1099.99922275, 1299.99922274, 1499.99922273,
1699.99922271, 99.99922293, 299.99922291, 499.99922291, 699.99922289,
899.99922287, 1099.99922286, 1299.99922284, 1499.99922283, 1699.99922282,
99.99922303, 299.99922302, 499.99922301, 699.999223, 899.99922298,
1099.99922296, 1299.99922295, 1499.99922294, 1699.99922292, 99.99922314,
299.99922312, 499.99922311, 699.9992231, 899.99922308, 1099.99922307,
1299.99922306, 1499.99922304, 1699.99922303, 99.99922324, 299.99922323,
499.99922322, 699.9992232, 899.99922319, 1099.99922317, 1299.99922316,
1499.99922315, 1699.99922313, 99.99922335, 299.99922333, 499.99922332,
699.99922331, 899.9992233, 1099.99922328, 1299.99922327, 1499.99922325,
1699.99922324, 99.99922345, 299.99922344, 499.99922342, 699.99922341,
899.9992234, 1099.99922338, 1299.99922337, 1499.99922335, 1699.99922334,
99.99922356, 299.99922354, 499.99922353, 699.99922352, 899.9992235,
1099.99922348, 1299.99922347, 1499.99922345, 1699.99922344, 99.99922367,
299.99922365, 499.99922364, 699.99922362, 899.99922361, 1099.99922359,
1299.99922358, 1499.99922356, 1699.99922355), Y = c(1699.9975638,
1699.99756369, 1699.99756357, 1699.99756347, 1699.99756336, 1699.99756325,
1699.99756314, 1699.99756303, 1699.99756292, 1499.99756399, 1499.99756388,
1499.99756377, 1499.99756366, 1499.99756355, 1499.99756344, 1499.99756333,
1499.99756322, 1499.99756311, 1299.99756418, 1299.99756408, 1299.99756396,
1299.99756386, 1299.99756375, 1299.99756363, 1299.99756353, 1299.99756342,
1299.99756331, 1099.99756438, 1099.99756427, 1099.99756416, 1099.99756405,
1099.99756394, 1099.99756384, 1099.99756372, 1099.99756361, 1099.99756351,
899.99756457, 899.99756446, 899.99756434, 899.99756424, 899.99756414,
899.99756403, 899.99756392, 899.99756381, 899.9975637, 699.99756477,
699.99756466, 699.99756454, 699.99756443, 699.99756433, 699.99756422,
699.99756411, 699.99756401, 699.99756389, 499.99756496, 499.99756485,
499.99756474, 499.99756463, 499.99756452, 499.99756441, 499.9975643,
499.9975642, 499.99756409, 299.99756516, 299.99756505, 299.99756494,
299.99756483, 299.99756472, 299.99756461, 299.9975645, 299.99756439,
299.99756428, 99.99756535, 99.99756524, 99.99756513, 99.99756502,
99.99756491, 99.9975648, 99.99756469, 99.99756458, 99.99756448
)), row.names = c("11", "12", "13", "14", "15", "16", "17", "18",
"19", "21", "22", "23", "24", "25", "26", "27", "28", "29", "31",
"32", "33", "34", "35", "36", "37", "38", "39", "41", "42", "43",
"44", "45", "46", "47", "48", "49", "51", "52", "53", "54", "55",
"56", "57", "58", "59", "61", "62", "63", "64", "65", "66", "67",
"68", "69", "71", "72", "73", "74", "75", "76", "77", "78", "79",
"81", "82", "83", "84", "85", "86", "87", "88", "89", "91", "92",
"93", "94", "95", "96", "97", "98", "99"), class = "data.frame")
mut2 = sapply(1:100, function(i) sample(c(0,1), size = nrow(Grid), replace = T))
## Functions #################
## Triple For loop
getRects <- function(trimtonOut, Grid){
len1 <- dim(trimtonOut)[2]
childli = childnew = rectidli = vector("list", len1);
for (i in 1:len1) {
childli[[i]] <- trimtonOut[,i]
}
for (u in 1:len1){
rectidli[[u]] <- which(childli[[u]]==1, arr.ind = T)
}
for (z in 1:len1) {
childnew[[z]] <- Grid[rectidli[[z]],];
}
return(childnew)
}
## Shortest Lapply
getRects1 <- function(trimtonOut, Grid){
lapply(1:dim(trimtonOut)[2], function(i) {
Grid[which(trimtonOut[,i]==1, arr.ind = T),]
})
}
## Shorter Lapply
getRects2 <- function(trimtonOut, Grid){
lapply(1:dim(trimtonOut)[2], function(i) {
tmp = which(trimtonOut[,i]==1, arr.ind = T)
Grid[tmp,]
})
}
## Longest Lapply
getRects3 <- function(trimtonOut, Grid){
lapply(1:dim(trimtonOut)[2], function(i) {
tmp = trimtonOut[,i]
tmp1 = which(tmp==1, arr.ind = T)
Grid[tmp1,]
})
}
## Execute and Compare #################
getRectV <- getRects(mut2, Grid)
getRectV1 <- getRects1(mut2, Grid)
getRectV2 <- getRects2(mut2, Grid)
getRectV3 <- getRects3(mut2, Grid)
identical(getRectV,getRectV1)
identical(getRectV,getRectV2)
identical(getRectV,getRectV3)
## Benchmark #################
library(microbenchmark)
# mut2 = sapply(1:400, function(i) sample(c(0,1), size = nrow(Grid), replace = T))
mc = microbenchmark(
loop = getRects(mut2, Grid),
lap1 = getRects1(mut2, Grid),
lap2 = getRects2(mut2, Grid),
lap3 = getRects3(mut2, Grid)
)
mc
Are you sure that those time differences are that significant?
library(microbenchmark)
# mut2 = sapply(1:400, function(i) sample(c(0,1), size = nrow(Grid), replace = T))
mc = microbenchmark(
loop = getRects(mut2, Grid),
lap1 = getRects1(mut2, Grid),
lap2 = getRects2(mut2, Grid),
lap3 = getRects3(mut2, Grid)
)
mc
#> Unit: milliseconds
#> expr min lq mean median uq max neval
#> loop 2.651485 2.699166 3.195301 2.756171 3.136741 8.010173 100
#> lap1 2.755571 2.828128 3.098850 2.877806 3.012487 7.427598 100
#> lap2 2.737105 2.808924 3.118260 2.863221 2.939996 13.706736 100
#> lap3 2.719101 2.787040 3.191893 2.852963 3.004811 8.490867 100
I want to change the color of a certain coordinate, actually is the same coordinate which has the annotation.
Any ideas?
p1 <- ggplot(HiBAP1517, aes(BPM, Yld)) +
geom_point(shape=16) +
geom_smooth(method=lm, se = F) +
theme(axis.title.x = element_text(color="black", size=14, face="bold"),
axis.title.y = element_text(color="black", size=14, face="bold"))
p2 <- p1 +
annotate(geom="text", x=1879, y=892.02, label="Rialto",
color="darkorange", size = 5, hjust=1, vjust=1.3, fontface =2)
p3 <- p2 +
annotate(geom="text", x=1654.75, y=834.2375, label="Savannah",
color="firebrick1", size = 5, hjust=1, vjust=1, fontface =2)
pfinal <- p3 +
labs(x = expression("AGDM"[PM]^{}*(gm^{-2})),
y = expression("GY"*(gm^{-2})))
This is my output, but I would like to change the color (instead of black) of those 2 coordinates:
Data sample:
Genotype,BPM,Yld
1,1767.793447,747.0708034
2,2074.815941,775.8880562
3,2197.933995,854.3810136
5,2085.627286,845.9306447
6,1908.97774,841.4318038
7,2120.24666,875.5534429
8,2226.617509,764.3849451
9,2035.68002,810.2658242
10,2153.727,861.7024631
11,1993.568134,782.5763292
12,2013.199982,822.6565187
13,2078.275912,837.2819632
14,2042.456487,802.6913977
16,1840.058841,767.6509829
17,2013.338146,801.2064103
18,2087.151352,822.1910199
19,1988.038384,859.573342
20,2083.092896,887.2783898
21,2072.905795,861.3044422
23,1849.744525,723.5014595
24,1785.04038,747.4940519
25,2078.402869,835.7669124
26,1698.390774,681.256732
27,2065.842661,852.3073467
28,2020.285009,811.6889063
29,2039.137248,821.7951099
30,1855.665106,781.0350726
31,1792.32475,744.9001931
32,1992.616447,860.7054072
33,2025.79755,834.1452611
34,2023.274784,835.4102703
35,1703.837196,682.9995098
36,1740.44177,713.3121368
37,1970.331012,816.5239645
38,1990.223669,838.9949534
39,2081.559891,822.5936391
40,1968.990856,852.1259441
41,2178.322511,920.80226
42,1887.572381,721.0746569
43,2103.964882,821.6521912
44,2097.040605,873.0062511
45,1864.779016,755.1746154
46,1935.743565,895.4951282
47,2191.797365,888.7284615
48,1968.150754,863.7490909
49,1858.735915,759.7144347
50,1933.34954,774.4202087
51,1680.540128,717.2402198
52,1748.214736,783.3395385
53,2183.694734,855.5897436
54,2142.662802,912.635349
55,1892.205584,776.5070164
56,2230.304238,887.8378102
57,2141.882287,903.7212821
58,1983.755009,815.5541958
59,1954.653032,743.0290819
60,1801.192428,718.5391635
61,1920.709571,808.6727692
62,1796.291216,699.0526007
63,2026.074655,909.3961954
64,1863.574774,729.9547929
65,1924.971832,770.2818388
66,2129.910527,794.0297343
67,2090.201938,809.6094569
68,1987.074651,731.8146606
69,2053.104282,839.4181954
70,1872.403668,787.2339391
71,1961.144455,824.335206
72,2135.414422,881.9237509
73,1857.780642,779.9428159
74,2058.696424,840.2234927
76,2169.489819,805.3868184
77,1891.844601,756.8752683
78,2099.708756,830.6765073
79,1976.981377,786.4878009
81,1932.909878,800.0033701
82,2101.603045,834.2990498
83,1867.872044,735.4201911
84,1870.947954,703.6186056
85,2135.962836,798.3315211
86,1859.497846,762.135947
87,1966.35974,776.6730353
88,2088.086246,808.0767316
89,1964.134743,851.5441764
90,2211.81001,866.3412008
91,1881.56405,805.7430148
92,1921.941058,725.2508829
93,1576.551861,606.5037422
95,2249.995426,882.4130493
96,2092.694714,778.8794369
97,2099.861152,840.9202391
98,1837.6733,760.0247786
99,1986.16533,796.1227279
100,1981.047087,747.7190033
Rialto,1879,892.02
Savannah,1654.75,834.2375
I assume you want to change the color of the points corresponding to the labels, since their precise coordinates along the x/y-axis aren't shown, and you'll have more work pinpointing them before the question about color comes up. If that's not the case, I'll delete my answer.
# define color corresponding to each genotype
HiBAP1517$color <- case_when(HiBAP1517$Genotype == "Savannah" ~ "firebrick1",
HiBAP1517$Genotype == "Rialto" ~ "darkorange",
TRUE ~ "black")
# plot
ggplot(HiBAP1517,
# specify color aesthetic here for both geom_point & geom_text to inherit
aes(x = BPM, y = Yld, color = color)) +
geom_point(shape = 16) +
geom_smooth(color = "#3366FF", # maintain default color for geom_smooth line
method = lm, se = F) +
# position labels based on their coordinates, rather than hard-code them via annotate()
geom_text(aes(label = ifelse(Genotype %in% c("Savannah", "Rialto"),
Genotype, "")),
hjust = 1, vjust = 1) +
# use defined colors directly
scale_color_identity() +
# other aesthetic parameters, irrelevant to the question at hand
labs(x = expression("AGDM"[PM]^{}*(gm^{-2})),
y = expression("GY"*(gm^{-2}))) +
theme_classic() +
theme(axis.title.x = element_text(color="black", size=14, face="bold"),
axis.title.y = element_text(color="black", size=14, face="bold"))
Data used:
> dput(HiBAP1517)
structure(list(Genotype = c("1", "2", "3", "5", "6", "7", "8",
"9", "10", "11", "12", "13", "14", "16", "17", "18", "19", "20",
"21", "23", "24", "25", "26", "27", "28", "29", "30", "31", "32",
"33", "34", "35", "36", "37", "38", "39", "40", "41", "42", "43",
"44", "45", "46", "47", "48", "49", "50", "51", "52", "53", "54",
"55", "56", "57", "58", "59", "60", "61", "62", "63", "64", "65",
"66", "67", "68", "69", "70", "71", "72", "73", "74", "76", "77",
"78", "79", "81", "82", "83", "84", "85", "86", "87", "88", "89",
"90", "91", "92", "93", "95", "96", "97", "98", "99", "100",
"Rialto", "Savannah"), BPM = c(1767.793447, 2074.815941, 2197.933995,
2085.627286, 1908.97774, 2120.24666, 2226.617509, 2035.68002,
2153.727, 1993.568134, 2013.199982, 2078.275912, 2042.456487,
1840.058841, 2013.338146, 2087.151352, 1988.038384, 2083.092896,
2072.905795, 1849.744525, 1785.04038, 2078.402869, 1698.390774,
2065.842661, 2020.285009, 2039.137248, 1855.665106, 1792.32475,
1992.616447, 2025.79755, 2023.274784, 1703.837196, 1740.44177,
1970.331012, 1990.223669, 2081.559891, 1968.990856, 2178.322511,
1887.572381, 2103.964882, 2097.040605, 1864.779016, 1935.743565,
2191.797365, 1968.150754, 1858.735915, 1933.34954, 1680.540128,
1748.214736, 2183.694734, 2142.662802, 1892.205584, 2230.304238,
2141.882287, 1983.755009, 1954.653032, 1801.192428, 1920.709571,
1796.291216, 2026.074655, 1863.574774, 1924.971832, 2129.910527,
2090.201938, 1987.074651, 2053.104282, 1872.403668, 1961.144455,
2135.414422, 1857.780642, 2058.696424, 2169.489819, 1891.844601,
2099.708756, 1976.981377, 1932.909878, 2101.603045, 1867.872044,
1870.947954, 2135.962836, 1859.497846, 1966.35974, 2088.086246,
1964.134743, 2211.81001, 1881.56405, 1921.941058, 1576.551861,
2249.995426, 2092.694714, 2099.861152, 1837.6733, 1986.16533,
1981.047087, 1879, 1654.75), Yld = c(747.0708034, 775.8880562,
854.3810136, 845.9306447, 841.4318038, 875.5534429, 764.3849451,
810.2658242, 861.7024631, 782.5763292, 822.6565187, 837.2819632,
802.6913977, 767.6509829, 801.2064103, 822.1910199, 859.573342,
887.2783898, 861.3044422, 723.5014595, 747.4940519, 835.7669124,
681.256732, 852.3073467, 811.6889063, 821.7951099, 781.0350726,
744.9001931, 860.7054072, 834.1452611, 835.4102703, 682.9995098,
713.3121368, 816.5239645, 838.9949534, 822.5936391, 852.1259441,
920.80226, 721.0746569, 821.6521912, 873.0062511, 755.1746154,
895.4951282, 888.7284615, 863.7490909, 759.7144347, 774.4202087,
717.2402198, 783.3395385, 855.5897436, 912.635349, 776.5070164,
887.8378102, 903.7212821, 815.5541958, 743.0290819, 718.5391635,
808.6727692, 699.0526007, 909.3961954, 729.9547929, 770.2818388,
794.0297343, 809.6094569, 731.8146606, 839.4181954, 787.2339391,
824.335206, 881.9237509, 779.9428159, 840.2234927, 805.3868184,
756.8752683, 830.6765073, 786.4878009, 800.0033701, 834.2990498,
735.4201911, 703.6186056, 798.3315211, 762.135947, 776.6730353,
808.0767316, 851.5441764, 866.3412008, 805.7430148, 725.2508829,
606.5037422, 882.4130493, 778.8794369, 840.9202391, 760.0247786,
796.1227279, 747.7190033, 892.02, 834.2375)), class = "data.frame", row.names = c(NA,
-96L))
I have done species accumulation curves and would like to plot the SAC results of different substrate sizeclasses in the same ggplot, with expected species richness on y-axis and number of sites samples on x-axis. The data features a cumulative number of samples in each sizeclass (column "sites"), the expected species richness (column "richness"), and substrate size classes 10, 20 and 30 (column "sc").
sites richness sc
1 1 0.6696915 10
2 2 1.2008513 10
3 3 1.6387310 10
4 4 2.0128472 10
5 5 2.3424933 10
6 6 2.6403239 10
sites richness sc
2836 1 1.000000 20
2837 2 1.703442 20
2838 3 2.249188 20
2839 4 2.706618 20
2840 5 3.110651 20
2841 6 3.479173 20
I want each sizeclass to have unique linetype. I used the following code for ggplot:
sac_kaikki<-ggplot(sac_data, aes(x=sites, y=richness,group=sc)) +
geom_line(aes(linetype=sc))+
coord_cartesian(xlim=c(0,100))+
theme(axis.title.y = element_blank())+
theme(axis.title.x = element_blank())
However, instead of getting three neat lines in different linetypes, I got [this jumbly muddly messy thing with more stripes than a herd of zebras][1]: https://i.stack.imgur.com/iD75K.jpg. I am sure the solution is rather simple, but for my life I am not able to figure it out.
// as Brookes kindly pointed out I should add some reproducible data, here is a subset of my data with dput, featuring 10 first observations of size classes 10 and 20:
dput(head(subset(sac_data,sac_data$sc=="10"),10))
structure(list(sites = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), richness = c(0.669691470054462,
1.20085134466255, 1.63873100707468, 2.01284716414471, 2.34249332096243,
2.64032389106845, 2.91468283244696, 3.17111526890278, 3.41334794519086,
3.64392468817362), sc = c("10", "10", "10", "10", "10", "10",
"10", "10", "10", "10")), .Names = c("sites", "richness", "sc"
), row.names = c(NA, 10L), class = "data.frame")
dput(head(subset(sac_data,sac_data$sc=="20"),10))
structure(list(sites = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), richness = c(0.999999999999987,
1.70344155844158, 2.24918831168832, 2.70661814764865, 3.11065087175364,
3.47917264517669, 3.82165739030286, 4.14341144680334, 4.44765475554031,
4.73653870494466), sc = c("20", "20", "20", "20", "20", "20",
"20", "20", "20", "20")), .Names = c("sites", "richness", "sc"
), row.names = 2836:2845, class = "data.frame")
// okay so for whatever reason, the plot works just fine if I plot only two sizeclasses, but including the third one produces the absurd plot I posted a picture of.
structure(list(sites = 1:10, richness = c(0.42857142857143, 0.838095238095238,
1.22932330827066, 1.60300751879699, 1.95989974937343, 2.30075187969924,
2.62631578947368, 2.93734335839598, 3.23458646616541, 3.5187969924812
), sc = c("30", "30", "30", "30", "30", "30", "30", "30", "30",
"30")), .Names = c("sites", "richness", "sc"), row.names = c(NA,
10L), class = "data.frame")
Works fine for me with your sample data:
a <- structure(list(sites = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), richness = c(0.669691470054462,
1.20085134466255, 1.63873100707468, 2.01284716414471, 2.34249332096243,
2.64032389106845, 2.91468283244696, 3.17111526890278, 3.41334794519086,
3.64392468817362), sc = c("10", "10", "10", "10", "10", "10",
"10", "10", "10", "10")), .Names = c("sites", "richness", "sc"
), row.names = c(NA, 10L), class = "data.frame")
b <- structure(list(sites = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), richness = c(0.999999999999987,
1.70344155844158, 2.24918831168832, 2.70661814764865, 3.11065087175364,
3.47917264517669, 3.82165739030286, 4.14341144680334, 4.44765475554031,
4.73653870494466), sc = c("20", "20", "20", "20", "20", "20",
"20", "20", "20", "20")), .Names = c("sites", "richness", "sc"
), row.names = 2836:2845, class = "data.frame")
c <- structure(list(sites = 1:10, richness = c(0.42857142857143, 0.838095238095238,
1.22932330827066, 1.60300751879699, 1.95989974937343, 2.30075187969924,
2.62631578947368, 2.93734335839598, 3.23458646616541, 3.5187969924812
), sc = c("30", "30", "30", "30", "30", "30", "30", "30", "30",
"30")), .Names = c("sites", "richness", "sc"), row.names = c(NA,
10L), class = "data.frame")
sac_data <- bind_rows(a, b, c)
Plotting:
ggplot(sac_data, aes(sites, richness, group = sc)) +
geom_line(aes(linetype = sc))
I am trying to compute the angle between two vectors, wherein one vector is fixed and the other vector is constantly moving. I already know the math in this and I found a code before:
theta <- acos( sum(a*b) / ( sqrt(sum(a * a)) * sqrt(sum(b * b)) ) )
I tried defining my a as:
a<-c(503,391)
and my b as:
b <- NM[, c("X","Y")]
When I apply the theta function I get:
Warning message:
In acos(sum(a * b)/(sqrt(sum(a * a)) * sqrt(sum(b * b)))) : NaNs produced
I would appreciate help to solve this.
And here is my sample data:
structure(list(A = structure(c(1L, 1L, 1L, 1L, 1L, 1L), .Label =
c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12",
"13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23",
"24", "25", "26", "27", "28", "29", "30", "31", "32", "33", "34",
"35", "36", "37", "38", "39", "40", "41", "42", "43", "44", "45",
"46", "47", "48", "49", "50", "51", "52", "53", "54", "55", "56",
"57", "58", "59", "60", "61", "62", "63", "64", "65", "66", "67",
"68", "69", "70", "71", "72", "73", "74", "75", "76", "77", "78",
"79", "80", "81", "82", "83", "84", "85", "86", "87", "88", "89",
"90", "91", "92", "93", "94", "95", "96", "97", "98", "99", "100",
"101", "102", "103", "104", "105", "106", "107", "108", "109",
"110"), class = "factor"), T = c(0.1, 0.2, 0.3, 0.4, 0.5, 0.6 ), X =
c(528.04, 528.04, 528.04, 528.04, 528.04, 528.04), Y = c(10.32,
10.32, 10.32, 10.32, 10.32, 10.32), V = c(0, 0, 0, 0, 0, 0),
GD = c(0, 0, 0, 0, 0, 0), ND = c(NA, 0, 0, 0, 0, 0), ND2 = c(NA,
0, 0, 0, 0, 0), TID = structure(c(1L, 1L, 1L, 1L, 1L, 1L), .Label = c("t1",
"t10", "t100", "t101", "t102", "t103", "t104", "t105", "t106",
"t107", "t108", "t109", "t11", "t110", "t12", "t13", "t14",
"t15", "t16", "t17", "t18", "t19", "t2", "t20", "t21", "t22",
"t23", "t24", "t25", "t26", "t27", "t28", "t29", "t3", "t30",
"t31", "t32", "t33", "t34", "t35", "t36", "t37", "t38", "t39",
"t4", "t40", "t41", "t42", "t43", "t44", "t45", "t46", "t47",
"t48", "t49", "t5", "t50", "t51", "t52", "t53", "t54", "t55",
"t56", "t57", "t58", "t59", "t6", "t60", "t61", "t62", "t63",
"t64", "t65", "t66", "t67", "t68", "t69", "t7", "t70", "t71",
"t72", "t73", "t74", "t75", "t76", "t77", "t78", "t79", "t8",
"t80", "t81", "t82", "t83", "t84", "t85", "t86", "t87", "t88",
"t89", "t9", "t90", "t91", "t92", "t93", "t94", "t95", "t96",
"t97", "t98", "t99"), class = "factor")), .Names = c("A", "T", "X", "Y", "V", "GD", "ND", "ND2", "TID"), row.names = c(NA, 6L),
class = "data.frame")
Your function is not vectorized. Try this:
theta <- function(x,Y) apply(Y,1,function(y,x) acos( sum(x*y) / ( sqrt(sum(x^2)) * sqrt(sum(y^2)) ) ),x=x)
a<-c(503,391)
b <- DF[, c("X","Y")]
theta(a,b)
# 1 2 3 4 5 6
#0.6412264 0.6412264 0.6412264 0.6412264 0.6412264 0.6412264
There is a problem with the acos and atan functions in this application, as you cannot compute angles for the full circle, only for the plus quadrant. In 2D, you need two values to specify a vector, and you need two values (sin and cos) to define it in degrees/radians up to 2pi. Here is an example of the acos problem:
plot(seq(1,10,pi/20)) ## A sequence of numbers
plot(cos(seq(1,10,pi/20))) ## Their cosines
plot(acos(cos(seq(1,10,pi/20)))) ## NOT Back to the original sequence
Here's an idea:
angle <- circular::coord2rad(x, y)
plot(angle)
where "(x,y)" has "angle"
as.numeric(angle)
gives the angle in radians (0,360). To report geographical directions, convert to degrees, and other things, you can use the added parameters for the circular function, e.g.:
x <- coord2rad(ea,eo, control.circular = list(type = "directions",units = "degrees"))
plot(x)
as.numeric(x)