Conditional Handling in R - r
I've been trying to create an error message when the ouput entered is wrong, for example, in this code instead of entering 4 digits number, it is entered a character.
I keep receiving an error. Any tips?
get_age <- function() {
yob <- readline("Please enter your year of birth: ")
age <- 2022 - as.numeric(yob)
return(age)
}
if (get_age != as.numeric(yob)) {
withCallingHandlers(
warning = function(cnd){
readline("This is not a number. Please, try again.")
},
print("please, enter a numerical value"),
return(get_age())
)
}
Related
Cannot GeoCode with Tigris
I'm trying to generate census tracts geoids for a batch of addresses. When I use the "append_geoid" function in the tigris package, r returns "Error in call_geolocator(as.character(address$street[i]), as.character(address$city[i]), : Bad Request (HTTP 400)". I used the example data given in the r documentation and it produced the same result. Code below. Any help on how to solve the issue is appreciated! airports <- dplyr::data_frame(street = "700 Catalina Dr", city = "Daytona Beach", state = "FL") append_geoid(airports, 'tr) # Populate Census Tract GEOID
EDIT: A fixed version of the package is on github:
remotes::install_github("walkerke/tigris")
Then try again
EDIT 2:
The version on github still seems to give errors, though different ones this time. The HTTP call succeeds, but the response doesn't contain what his function expects it to. I'd contact him or her.
My Initial Post:
I got the same message as you do.
I did: debug( call_geolocator )
And ran it again, this time stepping through it. After a few code lines it creates the url: https://geocoding.geo.census.gov/geocoder/geographies/address?street=700%20Catalina%20Dr&city=Daytona%20Beach&state=FL&benchmark=Public_AR_Census2010&vintage=Census2010_Census2010&layers=14&format=json
This url then fails. Opening this url in a browser also gives an error, saying invalid benchmark.
At this point it's about time to call the author and make him aware that his package is not working any more.
For reference, this is what the debug session looked like in my terminal, until I inspected the full url created and hit Q to stop debuging:
> debug( call_geolocator )
> append_geoid(airports, 'tract') # Populate Census Tract GEOID
debugging in: call_geolocator(as.character(address$street[i]), as.character(address$city[i]),
as.character(address$state[i]))
debug: {
call_start <- "https://geocoding.geo.census.gov/geocoder/geographies/address?"
if (is.na(zip)) {
url <- paste0("street=", utils::URLencode(street), "&city=",
utils::URLencode(city), "&state=", state)
}
if (!is.na(zip)) {
if (class(zip) == "character" & nchar(zip) == 5 & !grepl("\\D",
zip)) {
url <- paste0("street=", utils::URLencode(street),
"&city=", utils::URLencode(city), "&state=",
state, "&zip=", zip)
}
else {
message("'zip' (", paste0(zip), ") was not a 5-character-long string composed of :digits:. Using only street, city, state.")
url <- paste0("street=", utils::URLencode(street),
"&city=", utils::URLencode(city), "&state=",
state)
}
}
call_end <- "&benchmark=Public_AR_Census2010&vintage=Census2010_Census2010&layers=14&format=json"
url_full <- paste0(call_start, url, call_end)
r <- httr::GET(url_full)
httr::stop_for_status(r)
response <- httr::content(r)
if (length(response$result$addressMatches) == 0) {
message(paste0("Address (", street, " ", city, " ", state,
") returned no address matches. An NA was returned."))
return(NA_character_)
}
else {
if (length(response$result$addressMatches) > 1) {
message(paste0("Address (", street, " ", city, " ",
state, ") returned more than one address match. The first match was returned."))
}
return(response$result$addressMatches[[1]]$geographies$`Census Blocks`[[1]]$GEOID)
}
}
Browse[2]>
debug: call_start <- "https://geocoding.geo.census.gov/geocoder/geographies/address?"
Browse[2]>
debug: if (is.na(zip)) {
url <- paste0("street=", utils::URLencode(street), "&city=",
utils::URLencode(city), "&state=", state)
}
Browse[2]>
debug: url <- paste0("street=", utils::URLencode(street), "&city=",
utils::URLencode(city), "&state=", state)
Browse[2]>
debug: if (!is.na(zip)) {
if (class(zip) == "character" & nchar(zip) == 5 & !grepl("\\D",
zip)) {
url <- paste0("street=", utils::URLencode(street), "&city=",
utils::URLencode(city), "&state=", state, "&zip=",
zip)
}
else {
message("'zip' (", paste0(zip), ") was not a 5-character-long string composed of :digits:. Using only street, city, state.")
url <- paste0("street=", utils::URLencode(street), "&city=",
utils::URLencode(city), "&state=", state)
}
}
Browse[2]>
debug: call_end <- "&benchmark=Public_AR_Census2010&vintage=Census2010_Census2010&layers=14&format=json"
Browse[2]>
debug: url_full <- paste0(call_start, url, call_end)
Browse[2]>
debug: r <- httr::GET(url_full)
Browse[2]> url_full
[1] "https://geocoding.geo.census.gov/geocoder/geographies/address?street=700%20Catalina%20Dr&city=Daytona%20Beach&state=FL&benchmark=Public_AR_Census2010&vintage=Census2010_Census2010&layers=14&format=json"
Browse[2]> Q
Going to the human interface of this: https://geocoding.geo.census.gov/geocoder/locations/address?form
It does indeed look like the benchmark in that url above is no longer an available in the dropdown select box. Changing it to Public_AR_Census2020 instead gives another error, Invalid vintage in request. Changing 2010 to 2020 in that string results in a successfull HTTP request: https://geocoding.geo.census.gov/geocoder/geographies/address?street=700%20Catalina%20Dr&city=Daytona%20Beach&state=FL&benchmark=Public_AR_Census2020&vintage=Census2010_Census2010&layers=14&format=json .
This doesn't really help you much at this point, but at least you can contact the author with an indication that the problem can be solved and you could give him some info to start working with.
If you're savy, you could clone his package source and fix it yourself, offer the fix to him, but nevertheless use your own fixed package until he gets around.
R: hide cells in DT::datatable based on condition
I am trying to create a datatable with child rows: the user will be able to click on a name and see a list of links related to that name. However, the number of itens to show is different for each name.
> data1 <- data.frame(name = c("John", "Maria", "Afonso"),
a = c("abc", "def", "rty"),
b=c("ghj","lop",NA),
c=c("zxc","cvb",NA),
d=c(NA, "mko", NA))
> data1
name a b c d
1 John abc ghj zxc <NA>
2 Maria def lop cvb mko
3 Afonso rty <NA> <NA> <NA>
I am using varsExplore::datatable2 to hide specific columns:
varsExplore::datatable2(x=data1, vars=c("a","b","c","d"))
and it produces the below result
Is it possible to modify DT::datatable in order to only render cells that are not "null"? So, for example, if someone clicked on "Afonso", the table would only render "rty", thus hiding "null" values for the other columns (for this row), while still showing those columns if the user clicked "Maria" (that doesn't have any "null").
(Should I try a different approach in order to achieve this behavior?)
A look into the inner working of varsExplore::datatable2
Following your request I took a look into the varsExplore::datatable2 source code. And I found out that varsExplore::datatable2 calls varsExplore:::.callback2 (3: means that it's not an exported function) to create the javascript code. this function also calls varsExplore:::.child_row_table2 which returns a javascript function format(row_data) that formats the rowdata into the table you see.
A proposed solution
I simply used my js knowledge to change the output of varsExplore:::.child_row_table2 and I came up with the following :
.child_row_table2 <- function(x, pos = NULL) {
names_x <- paste0(names(x), ":")
text <- "
var format = function(d) {
text = '<div><table >' +
"
for (i in seq_along(pos)) {
text <- paste(text, glue::glue(
" ( d[{pos[i]}]!==null ? ( '<tr>' +
'<td>' + '{names_x[pos[i]]}' + '</td>' +
'<td>' + d[{pos[i]}] + '</td>' +
'</tr>' ) : '' ) + " ))
}
paste0(text,
"'</table></div>'
return text;};"
)
}
the only change I did was adding the d[{pos[i]}]!==null ? ....... : '' which will only show the column pos[i] when its value d[pos[i]] is not null.
Looking at the fact that loading the package and adding the function to the global environment won't do the trick, I forked it on github and commited the changes you can now install it by running (the github repo is a read-only cran mirror can't submit pull request)
devtools::install_github("moutikabdessabour/varsExplore")
EDIT
if you don't want to redownload the package I found a solution basically you'll need to override the datatable2 function :
first copy the source code into your R file located at path/to/your/Rfile
# the data.table way
data.table::fwrite(list(capture.output(varsExplore::datatable2)), quote=F, sep='\n', file="path/to/your/Rfile", append=T)
# the baseR way
fileConn<-file("path/to/your/Rfile", open='a')
writeLines(capture.output(varsExplore::datatable2), fileConn)
close(fileConn)
then you'll have to substitute the last ligne
DT::datatable(
x,
...,
escape = -2,
options = opts,
callback = DT::JS(.callback2(x = x, pos = c(0, pos)))
)
with :
DT::datatable(
x,
...,
escape = -2,
options = opts,
callback = DT::JS(gsub("('<tr>.+?(d\\[\\d+\\]).+?</tr>')" , "(\\2==null ? '' : \\1)", varsExplore:::.callback2(x = x, pos = c(0, pos))))
)
what this code is basically doing is adding the js condition using a regular expression.
Result
How can I solve the error when the user inputs only an "enter" in R?
I make a code based on a table game. At the beginning of the code, it must ask the player the name of the player, and when the player inputs an "enter", my code shows an error. I want that when the player inputs an "enter", the program says something like "This name is invalid", ask repeat asking the name of the player. Here is a part of my code:
repeat{
if(r==1){
print("Name Player 1: ")
name1=scan(,what="character",1)
if(any(name1==gamers)){
r=readline(prompt = "This player is already in the file. Would you like to change the name? \n 1. Yes \n 2. No \n Select an option: ")
if(r==0){
r<-99
}
Instead of print(...); name1=scan(...), I'd use readline, as such:
while (!nzchar(name1 <- readline("Name Player 1: "))) TRUE
# Name Player 1: <-- me just hitting <enter>
# Name Player 1: <-- again
# Name Player 1: r2evans
name1
# [1] "r2evans"
You might prefer to allow a max number of failed attempts, though, instead of requiring the user interrupt the process with ctrl-c, so perhaps:
tries <- 3L
while (tries > 0 && !nzchar(name1 <- readline("Name Player 1: "))) tries <- tries - 1L
# Name Player 1:
# Name Player 1:
# Name Player 1:
And the loop just stopped/exited. You "know" that the user chose to quit because after the loop, tries == 0L and !nzchar(name1) both indicate the user's intent.
How to check if subset is empty in R
I have a set of data with weight with time (t), I need to identify outliers of weight for every time (t), after which I need to send a notification email.
I'm using bloxplot($out) to identify the outliers, it seems to work, but I'm not sure if:
It's the correct way to use the boxplot?
I can't detect if the boxplot has no outlier or if its empty (or maybe, I'm using a wrong technique)
Or possibly the subset itself is empty (could be the root cause)
For now, I just need to trap the empty subset and check if out variable is empty or not.
Below is my R script code:
#i am a comment, and the compiler doesn't care about me
#load our libraries
library(ggplot2)
library(mailR)
#some variables to be used later
from<-""
to<-""
getwd()
setwd("C:\\Temp\\rwork")
#read the data file into a data(d) variable
d<-read.csv("testdata.csv", header=TRUE) #file
#get the current time(t)
t <-format(Sys.time(),"%H")
#create a subset of d based on t
sbset<-subset(d,Time==t)
#identify if outlier exists then send an email report
out<-boxplot(sbset$weight)$out
if(length(out)!=0){
#create a boxplot of the subset
boxplot(sbset$weight)
subject = paste("Attention: An Outlier is detected for Scheduled Job Run on Hour ",t)
message = toString(out) #sort(out)
}else{
subject = paste("No Outlier Identified")
message = ""
}
email<-send.mail(from=from,
to=to,
subject=subject,
body=message,
html=T,
smtp=list(host.name = "smtp.gmail.com",
port = 465,
user.name = from,
passwd = "", #password of sender email
ssl = TRUE),
authenticate=TRUE,
send=TRUE)
DATA
weight,Time,Chick,x
42,0,1,1
51,2,1,1
59,4,1,1
64,6,1,1
76,8,1,1
93,10,1,1
106,12,1,1
125,14,1,1
149,16,1,1
171,18,1,1
199,20,1,1
205,21,1,1
40,0,2,1
49,2,2,1
58,4,2,1
72,6,2,1
84,8,2,1
103,10,2,1
122,12,2,1
138,14,2,1
162,16,2,1
187,18,2,1
209,20,2,1
215,21,2,1
43,0,3,1
39,2,3,1
55,4,3,1
67,6,3,1
84,8,3,1
99,10,3,1
115,12,3,1
138,14,3,1
163,16,3,1
187,18,3,1
198,20,3,1
202,21,3,1
42,0,4,1
49,2,4,1
56,4,4,1
67,6,4,1
74,8,4,1
87,10,4,1
102,12,4,1
108,14,4,1
136,16,4,1
154,18,4,1
160,20,4,1
157,21,4,1
41,0,5,1
42,2,5,1
48,4,5,1
60,6,5,1
79,8,5,1
106,10,5,1
141,12,5,1
164,14,5,1
197,16,5,1
199,18,5,1
220,20,5,1
223,21,5,1
41,0,6,1
49,2,6,1
59,4,6,1
74,6,6,1
97,8,6,1
124,10,6,1
141,12,6,1
148,14,6,1
155,16,6,1
160,18,6,1
160,20,6,1
157,21,6,1
41,0,7,1
49,2,7,1
57,4,7,1
71,6,7,1
89,8,7,1
112,10,7,1
146,12,7,1
174,14,7,1
218,16,7,1
250,18,7,1
288,20,7,1
305,21,7,1
42,0,8,1
50,2,8,1
61,4,8,1
71,6,8,1
84,8,8,1
93,10,8,1
110,12,8,1
116,14,8,1
126,16,8,1
134,18,8,1
125,20,8,1
42,0,9,1
51,2,9,1
59,4,9,1
68,6,9,1
85,8,9,1
96,10,9,1
90,12,9,1
92,14,9,1
93,16,9,1
100,18,9,1
100,20,9,1
98,21,9,1
41,0,10,1
44,2,10,1
52,4,10,1
63,6,10,1
74,8,10,1
81,10,10,1
89,12,10,1
96,14,10,1
101,16,10,1
112,18,10,1
120,20,10,1
124,21,10,1
43,0,11,1
51,2,11,1
63,4,11,1
84,6,11,1
112,8,11,1
139,10,11,1
168,12,11,1
177,14,11,1
182,16,11,1
184,18,11,1
181,20,11,1
175,21,11,1
41,0,12,1
49,2,12,1
56,4,12,1
62,6,12,1
72,8,12,1
88,10,12,1
119,12,12,1
135,14,12,1
162,16,12,1
185,18,12,1
195,20,12,1
205,21,12,1
41,0,13,1
48,2,13,1
53,4,13,1
60,6,13,1
65,8,13,1
67,10,13,1
71,12,13,1
70,14,13,1
71,16,13,1
81,18,13,1
91,20,13,1
96,21,13,1
41,0,14,1
49,2,14,1
62,4,14,1
79,6,14,1
101,8,14,1
128,10,14,1
164,12,14,1
192,14,14,1
227,16,14,1
248,18,14,1
259,20,14,1
266,21,14,1
41,0,15,1
49,2,15,1
56,4,15,1
64,6,15,1
68,8,15,1
68,10,15,1
67,12,15,1
68,14,15,1
41,0,16,1
45,2,16,1
49,4,16,1
51,6,16,1
57,8,16,1
51,10,16,1
54,12,16,1
42,0,17,1
51,2,17,1
61,4,17,1
72,6,17,1
83,8,17,1
89,10,17,1
98,12,17,1
103,14,17,1
113,16,17,1
123,18,17,1
133,20,17,1
142,21,17,1
39,0,18,1
35,2,18,1
43,0,19,1
48,2,19,1
55,4,19,1
62,6,19,1
65,8,19,1
71,10,19,1
82,12,19,1
88,14,19,1
106,16,19,1
120,18,19,1
144,20,19,1
157,21,19,1
41,0,20,1
47,2,20,1
54,4,20,1
58,6,20,1
65,8,20,1
73,10,20,1
77,12,20,1
89,14,20,1
98,16,20,1
107,18,20,1
115,20,20,1
117,21,20,1
40,0,21,2
50,2,21,2
62,4,21,2
86,6,21,2
125,8,21,2
163,10,21,2
217,12,21,2
240,14,21,2
275,16,21,2
307,18,21,2
318,20,21,2
331,21,21,2
41,0,22,2
55,2,22,2
64,4,22,2
77,6,22,2
90,8,22,2
95,10,22,2
108,12,22,2
111,14,22,2
131,16,22,2
148,18,22,2
164,20,22,2
167,21,22,2
43,0,23,2
52,2,23,2
61,4,23,2
73,6,23,2
90,8,23,2
Your first use of boxplot is unnecessarily creating a plot, you can use
out <- boxplot.stats(sbset$weight)$out
for a little efficiency.
You are interested in the presence of rows, but length(sbset) will return the number of columns. I suggest instead nrow or NROW.
if (NROW(out) > 0) {
boxplot(sbset$weight)
# ...
} else {
# ...
}
Regex in if else statement in R
I have a rather simple question. I am trying to get the if else statement below to work.
It is supposed to assign '1' if the if statement is met, 0 otherwise.
My problem is that I cannot get the regex in the if statement to work ('\w*|\W*). It is supposed to specify the condition that the string either is "Registration Required" or Registration required followed by any character. I cannot specify the exact cases, because following the "Registration required" (in the cases where something follows), it will usually be a date (varying for each observation) and a few words.
Registration_cleaned <- c()
for (i in 1:length(Registration)) {
if (Registration[i] == ' Registration Required\\w*|\\W*') {
Meta_Registration_cleaned <- 1
} else {
Meta_Registration_cleaned <- 0
}
Registration_cleaned <- c(Registration_cleaned, Meta_Registration_cleaned)
}
You may use transform together with ifelse function to set the Meta_Registration_cleaned.
For matching the regular expression grep function can be used with pattern "Registration Required\w*".
Registration <- data.frame(reg = c("Registration Required", "Registration Required ddfdqf","some str", "Regixxstration Required ddfdqf"),stringsAsFactors = F)
transform(Registration,Meta_Registration_cleaned = ifelse(grepl("Registration Required\\w*",Registration[,"reg"]), 1, 0))
Gives result:
reg Meta_Registration_cleaned
1 Registration Required 1
2 Registration Required ddfdqf 1
3 some str 0
4 Regixxstration Required ddfdqf 0
I might have misunderstood the OP completely, because I have understood the question entirely differently than anyone else here.
My comment earlier suggested looking for the regex at the end of the string.
Registration <- data.frame(reg = c("Registration Required", "Registration Required ddfdqf","Registration Required 10/12/2000"),stringsAsFactors = F)
#thanks #user1653941 for drafting the sample vector
Registration$Meta_Registration_cleaned <- grepl('Registration required$', Registration$reg, ignore.case = TRUE)
Registration
1 Registration Required TRUE
2 Registration Required ddfdqf FALSE
3 Registration Required 10/12/2000 FALSE
I understand the OP as such that the condition is: Either the string "Registration required" without following characters, or... anything else. Looking forward to the OPs comment.